diff --git a/backend/asmgen.ml b/backend/asmgen.ml index 68c88e81199..73abeab73b7 100644 --- a/backend/asmgen.ml +++ b/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 diff --git a/backend/cfg/cfg.ml b/backend/cfg/cfg.ml index 6459b7db1c9..2e02380f629 100644 --- a/backend/cfg/cfg.ml +++ b/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 diff --git a/backend/cfg/cfg.mli b/backend/cfg/cfg.mli index 37d13e863a5..c91552d792e 100644 --- a/backend/cfg/cfg.mli +++ b/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 diff --git a/backend/cfg/cfg_with_layout.ml b/backend/cfg/cfg_with_layout.ml index 68fa821e7d6..2290e95b82b 100644 --- a/backend/cfg/cfg_with_layout.ml +++ b/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; diff --git a/backend/cfg/cfg_with_layout.mli b/backend/cfg/cfg_with_layout.mli index 9fd6938be10..76cd8f71d3c 100644 --- a/backend/cfg/cfg_with_layout.mli +++ b/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 diff --git a/ocaml/driver/main_args.ml b/ocaml/driver/main_args.ml index 73feb49ddff..a763d340a69 100644 --- a/ocaml/driver/main_args.ml +++ b/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 diff --git a/ocaml/driver/main_args.mli b/ocaml/driver/main_args.mli index 15ce67893f1..9ae5d61cbc4 100644 --- a/ocaml/driver/main_args.mli +++ b/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 diff --git a/ocaml/utils/clflags.ml b/ocaml/utils/clflags.ml index 719fd9c692d..c339a0f8183 100644 --- a/ocaml/utils/clflags.ml +++ b/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 *) diff --git a/ocaml/utils/clflags.mli b/ocaml/utils/clflags.mli index 7a898823041..b197e63f3a2 100644 --- a/ocaml/utils/clflags.mli +++ b/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 diff --git a/testsuite/tools/codegen_main.ml b/testsuite/tools/codegen_main.ml index d0b3d40434f..4faba230897 100644 --- a/testsuite/tools/codegen_main.ml +++ b/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, "";