Add "-dcfg" flag to ocamlopt

backend/asmgen.ml

@@ -41,6 +41,11 @@ let pass_dump_linear_if ppf flag message phrase =
   if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase;
   phrase
 
+let pass_dump_cfg_if ppf flag message c =
+  if !flag then
+    fprintf ppf "*** %s@.%a@." message (Cfg_with_layout.dump ~msg:"") c;
+  c
+
 let start_from_emit = ref true
 
 let should_save_before_emit () =
@@ -178,12 +183,17 @@ let compile_fundecl ~ppf_dump fd_cmm =
       res)
   ++ pass_dump_linear_if ppf_dump dump_linear "Linearized code"
   ++ (fun (fd : Linear.fundecl) ->
-      if !use_ocamlcfg then begin
-        let cfg = Linear_to_cfg.run fd ~preserve_orig_labels:true in
+    if !use_ocamlcfg then begin
+      fd
+      ++ Profile.record ~accumulate:true "linear_to_cfg"
+           (Linear_to_cfg.run ~preserve_orig_labels:true)
+      ++ pass_dump_cfg_if ppf_dump dump_cfg "After linear_to_cfg"
+      ++ Profile.record ~accumulate:true "cfg_to_linear" (fun cfg ->
         let fun_body, fun_tailrec_entry_point_label = Cfg_to_linear.run cfg in
-        { fd with Linear.fun_body; fun_tailrec_entry_point_label; }
-      end else
-        fd)
+        { fd with Linear.fun_body; fun_tailrec_entry_point_label; })
+      ++ pass_dump_linear_if ppf_dump dump_linear "After cfg_to_linear"
+    end else
+      fd)
   ++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl
   ++ pass_dump_linear_if ppf_dump dump_scheduling "After instruction scheduling"
   ++ save_linear

backend/cfg/cfg.ml

@@ -183,93 +183,94 @@ let intop (op : Mach.integer_operation) =
   | Icomp cmp -> intcomp cmp
   | Icheckbound -> assert false
 
-let print_op oc = function
-  | Move -> Printf.fprintf oc "mov"
-  | Spill -> Printf.fprintf oc "spill"
-  | Reload -> Printf.fprintf oc "reload"
-  | Const_int n -> Printf.fprintf oc "const_int %nd" n
-  | Const_float f -> Printf.fprintf oc "const_float %Ld" f
-  | Const_symbol s -> Printf.fprintf oc "const_symbol %s" s
-  | Stackoffset n -> Printf.fprintf oc "stackoffset %d" n
-  | Load _ -> Printf.fprintf oc "load"
-  | Store _ -> Printf.fprintf oc "store"
-  | Intop op -> Printf.fprintf oc "intop %s" (intop op)
-  | Intop_imm (op, n) -> Printf.fprintf oc "intop %s %d" (intop op) n
-  | Negf -> Printf.fprintf oc "negf"
-  | Absf -> Printf.fprintf oc "absf"
-  | Addf -> Printf.fprintf oc "addf"
-  | Subf -> Printf.fprintf oc "subf"
-  | Mulf -> Printf.fprintf oc "mulf"
-  | Divf -> Printf.fprintf oc "divf"
-  | Compf _ -> Printf.fprintf oc "compf"
-  | Floatofint -> Printf.fprintf oc "floattoint"
-  | Intoffloat -> Printf.fprintf oc "intoffloat"
-  | Specific _ -> Printf.fprintf oc "specific"
+let dump_op ppf = function
+  | Move -> Format.fprintf ppf "mov"
+  | Spill -> Format.fprintf ppf "spill"
+  | Reload -> Format.fprintf ppf "reload"
+  | Const_int n -> Format.fprintf ppf "const_int %nd" n
+  | Const_float f -> Format.fprintf ppf "const_float %F" (Int64.float_of_bits f)
+  | Const_symbol s -> Format.fprintf ppf "const_symbol %s" s
+  | Stackoffset n -> Format.fprintf ppf "stackoffset %d" n
+  | Load _ -> Format.fprintf ppf "load"
+  | Store _ -> Format.fprintf ppf "store"
+  | Intop op -> Format.fprintf ppf "intop %s" (intop op)
+  | Intop_imm (op, n) -> Format.fprintf ppf "intop %s %d" (intop op) n
+  | Negf -> Format.fprintf ppf "negf"
+  | Absf -> Format.fprintf ppf "absf"
+  | Addf -> Format.fprintf ppf "addf"
+  | Subf -> Format.fprintf ppf "subf"
+  | Mulf -> Format.fprintf ppf "mulf"
+  | Divf -> Format.fprintf ppf "divf"
+  | Compf _ -> Format.fprintf ppf "compf"
+  | Floatofint -> Format.fprintf ppf "floattoint"
+  | Intoffloat -> Format.fprintf ppf "intoffloat"
+  | Specific _ -> Format.fprintf ppf "specific"
   | Probe { name; handler_code_sym } ->
-    Printf.fprintf oc "probe %s %s" name handler_code_sym
-  | Probe_is_enabled { name } -> Printf.fprintf oc "probe_is_enabled %s" name
-  | Name_for_debugger _ -> Printf.fprintf oc "name_for_debugger"
+    Format.fprintf ppf "probe %s %s" name handler_code_sym
+  | Probe_is_enabled { name } -> Format.fprintf ppf "probe_is_enabled %s" name
+  | Name_for_debugger _ -> Format.fprintf ppf "name_for_debugger"
 
-let print_call oc = function
+let dump_call ppf = function
   | P prim_call -> (
     match prim_call with
     | External { func_symbol : string; _ } ->
-      Printf.fprintf oc "external %s" func_symbol
-    | Alloc { bytes : int; _ } -> Printf.fprintf oc "alloc %d" bytes
-    | Checkbound _ -> Printf.fprintf oc "checkbound")
+      Format.fprintf ppf "external %s" func_symbol
+    | Alloc { bytes : int; _ } -> Format.fprintf ppf "alloc %d" bytes
+    | Checkbound _ -> Format.fprintf ppf "checkbound")
   | F func_call -> (
     match func_call with
-    | Indirect -> Printf.fprintf oc "indirect"
+    | Indirect -> Format.fprintf ppf "indirect"
     | Direct { func_symbol : string; _ } ->
-      Printf.fprintf oc "direct %s" func_symbol)
+      Format.fprintf ppf "direct %s" func_symbol)
 
-let print_basic oc i =
-  Printf.fprintf oc "%d: " i.id;
+let dump_basic ppf i =
+  let open Format in
+  fprintf ppf "%d: " i.id;
   match i.desc with
-  | Op op -> print_op oc op
+  | Op op -> dump_op ppf op
   | Call call ->
-    Printf.fprintf oc "Call ";
-    print_call oc call
-  | Reloadretaddr -> Printf.fprintf oc "Reloadretaddr"
-  | Pushtrap { lbl_handler } ->
-    Printf.fprintf oc "Pushtrap handler=%d" lbl_handler
-  | Poptrap -> Printf.fprintf oc "Poptrap"
-  | Prologue -> Printf.fprintf oc "Prologue"
+    fprintf ppf "Call ";
+    dump_call ppf call
+  | Reloadretaddr -> fprintf ppf "Reloadretaddr"
+  | Pushtrap { lbl_handler } -> fprintf ppf "Pushtrap handler=%d" lbl_handler
+  | Poptrap -> fprintf ppf "Poptrap"
+  | Prologue -> fprintf ppf "Prologue"
 
-let print_terminator oc ?(sep = "\n") ti =
-  Printf.fprintf oc "%d: " ti.id;
+let dump_terminator ppf ?(sep = "\n") ti =
+  let open Format in
+  fprintf ppf "%d: " ti.id;
   match ti.desc with
-  | Never -> Printf.fprintf oc "deadend%s" sep
-  | Always l -> Printf.fprintf oc "goto %d%s" l sep
+  | Never -> fprintf ppf "deadend%s" sep
+  | Always l -> fprintf ppf "goto %d%s" l sep
   | Parity_test { ifso; ifnot } ->
-    Printf.fprintf oc "if even goto %d%sif odd goto %d%s" ifso sep ifnot sep
+    fprintf ppf "if even goto %d%sif odd goto %d%s" ifso sep ifnot sep
   | Truth_test { ifso; ifnot } ->
-    Printf.fprintf oc "if true goto %d%sif false goto %d%s" ifso sep ifnot sep
+    fprintf ppf "if true goto %d%sif false goto %d%s" ifso sep ifnot sep
   | Float_test { lt; eq; gt; uo } ->
-    Printf.fprintf oc "if < goto %d%s" lt sep;
-    Printf.fprintf oc "if = goto %d%s" eq sep;
-    Printf.fprintf oc "if > goto %d%s" gt sep;
-    Printf.fprintf oc "if uo goto %d%s" uo sep
+    fprintf ppf "if < goto %d%s" lt sep;
+    fprintf ppf "if = goto %d%s" eq sep;
+    fprintf ppf "if > goto %d%s" gt sep;
+    fprintf ppf "if uo goto %d%s" uo sep
   | Int_test { lt; eq; gt; is_signed; imm } ->
     let cmp =
       Printf.sprintf " %s%s"
         (if is_signed then "s" else "u")
         (match imm with None -> "" | Some i -> " " ^ Int.to_string i)
     in
-    Printf.fprintf oc "if <%s goto %d%s" cmp lt sep;
-    Printf.fprintf oc "if =%s goto %d%s" cmp eq sep;
-    Printf.fprintf oc "if >%s goto %d%s" cmp gt sep
+    fprintf ppf "if <%s goto %d%s" cmp lt sep;
+    fprintf ppf "if =%s goto %d%s" cmp eq sep;
+    fprintf ppf "if >%s goto %d%s" cmp gt sep
   | Switch labels ->
-    Printf.fprintf oc "switch%s" sep;
+    fprintf ppf "switch%s" sep;
     for i = 0 to Array.length labels - 1 do
-      Printf.fprintf oc "case %d: goto %d%s" i labels.(i) sep
+      fprintf ppf "case %d: goto %d%s" i labels.(i) sep
     done
   | Call_no_return { func_symbol : string; _ } ->
-    Printf.fprintf oc "Call_no_return %s%s" func_symbol sep
-  | Return -> Printf.fprintf oc "Return%s" sep
-  | Raise _ -> Printf.fprintf oc "Raise%s" sep
-  | Tailcall (Self _) -> Printf.fprintf oc "Tailcall self%s" sep
-  | Tailcall (Func _) -> Printf.fprintf oc "Tailcall%s" sep
+    fprintf ppf "Call_no_return %s%s" func_symbol sep
+  | Return -> fprintf ppf "Return%s" sep
+  | Raise _ -> fprintf ppf "Raise%s" sep
+  | Tailcall (Self _) -> fprintf ppf "Tailcall self%s" sep
+  | Tailcall (Func _) -> fprintf ppf "Tailcall%s" sep
 
 let can_raise_terminator (i : terminator) =
   match i with
@@ -278,3 +279,9 @@ let can_raise_terminator (i : terminator) =
   | Switch _ | Return
   | Tailcall (Self _) ->
     false
+
+let print_basic oc i =
+  Format.kasprintf (Printf.fprintf oc "%s") "%a" dump_basic i
+
+let print_terminator oc ?sep ti =
+  Format.kasprintf (Printf.fprintf oc "%s") "%a" (dump_terminator ?sep) ti

backend/cfg/cfg.mli

@@ -111,6 +111,11 @@ val register_predecessors_for_all_blocks : t -> unit
 
 (** Printing *)
 
+val dump_terminator :
+  Format.formatter -> ?sep:string -> terminator instruction -> unit
+
+val dump_basic : Format.formatter -> basic instruction -> unit
+
 val print_terminator :
   out_channel -> ?sep:string -> terminator instruction -> unit
 

backend/cfg/cfg_with_layout.ml

@@ -66,27 +66,30 @@ let is_trap_handler t label =
 
 (* Printing utilities for debug *)
 
-let print t oc msg =
-  Printf.fprintf oc "cfg for %s\n" msg;
-  Printf.fprintf oc "%s\n" t.cfg.fun_name;
-  Printf.fprintf oc "layout.length=%d\n" (List.length t.layout);
-  Printf.fprintf oc "blocks.length=%d\n" (Label.Tbl.length t.cfg.blocks);
+let dump ppf t ~msg =
+  let open Format in
+  fprintf ppf "\ncfg for %s\n" msg;
+  fprintf ppf "%s\n" t.cfg.fun_name;
+  fprintf ppf "layout.length=%d\n" (List.length t.layout);
+  fprintf ppf "blocks.length=%d\n" (Label.Tbl.length t.cfg.blocks);
   let print_block label =
     let block = Label.Tbl.find t.cfg.blocks label in
-    Printf.fprintf oc "\n%d:\n" label;
-    List.iter (Cfg.print_basic oc) block.body;
-    Cfg.print_terminator oc block.terminator;
-    Printf.fprintf oc "\npredecessors:";
-    Label.Set.iter (Printf.fprintf oc " %d") block.predecessors;
-    Printf.fprintf oc "\nsuccessors:";
-    Label.Set.iter (Printf.fprintf oc " %d")
+    fprintf ppf "\n%d:\n" label;
+    List.iter (Cfg.dump_basic ppf) block.body;
+    Cfg.dump_terminator ppf block.terminator;
+    fprintf ppf "\npredecessors:";
+    Label.Set.iter (fprintf ppf " %d") block.predecessors;
+    fprintf ppf "\nsuccessors:";
+    Label.Set.iter (fprintf ppf " %d")
       (Cfg.successor_labels ~normal:true ~exn:false block);
-    Printf.fprintf oc "\nexn-successors:";
-    Label.Set.iter (Printf.fprintf oc " %d")
+    fprintf ppf "\nexn-successors:";
+    Label.Set.iter (fprintf ppf " %d")
       (Cfg.successor_labels ~normal:false ~exn:true block)
   in
   List.iter print_block t.layout
 
+let print t oc msg = Printf.fprintf oc "%s" (Format.asprintf "%a" (dump ~msg) t)
+
 let print_dot t ?(show_instr = true) ?(show_exn = true) ?annotate_block
     ?annotate_succ oc =
   Printf.fprintf oc "strict digraph \"%s\" {\n" t.cfg.fun_name;

backend/cfg/cfg_with_layout.mli

@@ -59,3 +59,5 @@ val save_as_dot :
   unit
 
 val print : t -> out_channel -> string -> unit
+
+val dump : Format.formatter -> t -> msg:string -> unit

ocaml/driver/main_args.ml

@@ -799,6 +799,10 @@ let mk_dcamlprimc f =
   "-dcamlprimc", Arg.Unit f, " (undocumented)"
 ;;
 
+let mk_dcfg f =
+  "-dcfg", Arg.Unit f, " (undocumented)"
+;;
+
 let mk_dcmm f =
   "-dcmm", Arg.Unit f, " (undocumented)"
 ;;
@@ -1388,6 +1392,7 @@ module type Optcommon_options = sig
   val _dflambda_verbose : unit -> unit
   val _drawclambda : unit -> unit
   val _dclambda : unit -> unit
+  val _dcfg : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit
@@ -1867,6 +1872,7 @@ struct
     mk_dfexpr F._dfexpr;
     mk_dflexpect F._dflexpect;
     mk_dclosure_offsets F._dclosure_offsets;
+    mk_dcfg F._dcfg;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
@@ -2040,6 +2046,7 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_dclambda F._dclambda;
     mk_drawflambda F._drawflambda;
     mk_dflambda F._dflambda;
+    mk_dcfg F._dcfg;
     mk_dcmm F._dcmm;
     mk_dsel F._dsel;
     mk_dcombine F._dcombine;
@@ -2219,6 +2226,7 @@ module Default = struct
     let _dalloc = set dump_regalloc
     let _davail () = dump_avail := true
     let _dclambda = set dump_clambda
+    let _dcfg = set dump_cfg
     let _dcmm = set dump_cmm
     let _dcombine = set dump_combine
     let _dcse = set dump_cse

ocaml/driver/main_args.mli

@@ -204,6 +204,7 @@ module type Optcommon_options = sig
   val _dflambda_verbose : unit -> unit
   val _drawclambda : unit -> unit
   val _dclambda : unit -> unit
+  val _dcfg : unit -> unit
   val _dcmm : unit -> unit
   val _dsel : unit -> unit
   val _dcombine : unit -> unit

ocaml/utils/clflags.ml

@@ -117,6 +117,7 @@ let optimize_for_speed = ref true       (* -compact *)
 and opaque = ref false                  (* -opaque *)
 
 and dump_cmm = ref false                (* -dcmm *)
+let dump_cfg = ref false                (* -dcfg *)
 let dump_selection = ref false          (* -dsel *)
 let dump_cse = ref false                (* -dcse *)
 let dump_live = ref false               (* -dlive *)

ocaml/utils/clflags.mli

@@ -116,6 +116,7 @@ val dump_instr : bool ref
 val keep_camlprimc_file : bool ref
 val keep_asm_file : bool ref
 val optimize_for_speed : bool ref
+val dump_cfg : bool ref
 val dump_cmm : bool ref
 val dump_selection : bool ref
 val dump_cse : bool ref

testsuite/tools/codegen_main.ml

@@ -59,6 +59,7 @@ let main() =
      "-S", Arg.Set write_asm_file,
        " Output file to filename.s (default is stdout)";
      "-g", Arg.Set Clflags.debug, "";
+     "-dcfg", Arg.Set dump_cfg, "";
      "-dcmm", Arg.Set dump_cmm, "";
      "-dcse", Arg.Set dump_cse, "";
      "-dsel", Arg.Set dump_selection, "";