Regalloc: liveness annotatons for debugging

compiler/src/regalloc.ml

@@ -1070,6 +1070,45 @@ let global_allocation translate_var get_internal_size (funcs: ('info, 'asm) func
   List.iter allocate_one Arch.all_registers;
 
   List.iter (fun f -> allocate_forced_registers return_addresses translate_var nv vars conflicts f a) funcs;
+
+  if !Glob_options.debug then begin
+      (* Prints the program with forced registers, equivalence classes, and liveness information *)
+      let open Format in
+      let open PrintCommon in
+      let open Printer in
+      let pp_variable fmt i = fprintf fmt "v%d" i in
+      let pp_reg fmt r = pp_var fmt ~debug:false r in
+      let pp_nonreg fmt x = pp_var fmt ~debug:true x in
+      let pp_decl_type fmt x = fprintf fmt "%a %a" pp_kind x.v_kind pp_ty x.v_ty in
+      let pp_var fmt x =
+        match Hv.find vars x with
+        | exception Not_found -> pp_nonreg fmt x
+        | i -> match A.find i a with
+               | Some r -> pp_reg fmt r
+               | None -> pp_variable fmt i
+      in
+      let pp_locals fmt s =
+        let tbl = ref IntMap.empty in
+        Sv.iter (fun x ->
+            match Hv.find vars x with
+            | exception Not_found -> fprintf fmt "%a %a@ " pp_decl_type x pp_nonreg x
+            | i -> if A.find i a = None then tbl := IntMap.modify_def [] i (List.cons x) !tbl
+          ) s;
+        IntMap.iter (fun i -> function
+            | [] -> ()
+            | x :: _ as xs -> fprintf fmt "%a %a /* %a */@ " pp_decl_type x pp_variable i (pp_list ", " pp_nonreg) xs
+          ) !tbl
+      in
+      let pp_liveset fmt s = pp_list "@ " pp_var fmt (Sv.elements s) in
+      let pp_info fmt (i, o) =
+        fprintf fmt "@[<h>/* Live-in:  %a */@]@ " pp_liveset i;
+        fprintf fmt "@[<h>/* Live-out: %a */@]@ " pp_liveset o
+      in
+      eprintf "Ready to allocate variables to registers:@.";
+      liveness_table |> Hf.iter (fun _fn ->
+        printf "%a@." (pp_fun ~pp_locals ~pp_info (pp_opn Arch.reg_size Arch.asmOp) pp_var))
+    end;
+
   greedy_allocation vars nv conflicts fr a;
   let subst = var_subst_of_allocation vars a in