From b37d42c5be53f3342127e67df5da46cb35b26433 Mon Sep 17 00:00:00 2001 From: Valentin Gatien-Baron Date: Sun, 15 Jul 2018 16:33:40 -0400 Subject: [PATCH] Add option to dump the output of e.g. -dlambda in a file --- Changes | 4 + asmcomp/asmgen.ml | 82 +++++++++---------- asmcomp/asmgen.mli | 6 +- asmcomp/asmlink.ml | 25 +++--- asmcomp/asmlink.mli | 4 +- asmcomp/asmpackager.ml | 16 ++-- asmcomp/asmpackager.mli | 2 +- asmcomp/cmmgen.ml | 20 ++--- asmcomp/cmmgen.mli | 3 +- asmcomp/un_anf.ml | 5 +- asmcomp/un_anf.mli | 3 +- bytecomp/bytepackager.ml | 12 +-- bytecomp/bytepackager.mli | 3 +- driver/compenv.ml | 12 +-- driver/compenv.mli | 8 +- driver/compile.ml | 35 ++++---- driver/compile.mli | 6 +- driver/compmisc.ml | 14 ++++ driver/compmisc.mli | 2 + driver/main.ml | 16 ++-- driver/main_args.ml | 7 ++ driver/main_args.mli | 1 + driver/optcompile.ml | 45 +++++----- driver/optcompile.mli | 5 +- driver/optmain.ml | 19 +++-- middle_end/augment_specialised_args.ml | 3 +- middle_end/inline_and_simplify.ml | 7 +- middle_end/inline_and_simplify.mli | 1 + middle_end/inline_and_simplify_aux.ml | 5 +- middle_end/inline_and_simplify_aux.mli | 4 + middle_end/middle_end.ml | 20 ++--- middle_end/middle_end.mli | 2 +- middle_end/pass_wrapper.ml | 8 +- middle_end/pass_wrapper.mli | 3 +- middle_end/remove_free_vars_equal_to_args.ml | 4 +- middle_end/remove_free_vars_equal_to_args.mli | 5 +- middle_end/unbox_free_vars_of_closures.ml | 3 +- testsuite/tools/codegen_main.ml | 4 +- tools/ocamlcp.ml | 1 + tools/ocamloptp.ml | 1 + toplevel/opttopdirs.ml | 2 +- toplevel/opttoploop.ml | 6 +- utils/clflags.ml | 2 + utils/clflags.mli | 2 + 44 files changed, 253 insertions(+), 185 deletions(-) diff --git a/Changes b/Changes index 2ca6f0b3061b..bebe6de7d826 100644 --- a/Changes +++ b/Changes @@ -108,6 +108,10 @@ Working version returns a syntax tree, to replace the print that was there already (Valentin Gatien-Baron) +- GPR#1913: new flag -dump-into-file to print debug output like -dlambda into + a file named after the file being built, instead of on stderr. + (Valentin Gatien-Baron, review by Thomas Refis) + - GPR#1921: in the compilation context passed to ppx extensions, add more configuration options related to type-checking: -rectypes, -principal, -alias-deps, -unboxed-types, -unsafe-string diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 99e7dbe0d32c..24b5fa946ca3 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -74,73 +74,73 @@ let raw_clambda_dump_if ppf end; if !dump_cmm then Format.fprintf ppf "@.cmm:@." -let rec regalloc ppf round fd = +let rec regalloc ~ppf_dump round fd = if round > 50 then fatal_error(fd.Mach.fun_name ^ ": function too complex, cannot complete register allocation"); - dump_if ppf dump_live "Liveness analysis" fd; + dump_if ppf_dump dump_live "Liveness analysis" fd; if !use_linscan then begin (* Linear Scan *) Interval.build_intervals fd; - if !dump_interval then Printmach.intervals ppf (); + if !dump_interval then Printmach.intervals ppf_dump (); Linscan.allocate_registers() end else begin (* Graph Coloring *) Interf.build_graph fd; - if !dump_interf then Printmach.interferences ppf (); - if !dump_prefer then Printmach.preferences ppf (); + if !dump_interf then Printmach.interferences ppf_dump (); + if !dump_prefer then Printmach.preferences ppf_dump (); Coloring.allocate_registers() end; - dump_if ppf dump_regalloc "After register allocation" fd; + dump_if ppf_dump dump_regalloc "After register allocation" fd; let (newfd, redo_regalloc) = Reload.fundecl fd in - dump_if ppf dump_reload "After insertion of reloading code" newfd; + dump_if ppf_dump dump_reload "After insertion of reloading code" newfd; if redo_regalloc then begin - Reg.reinit(); Liveness.fundecl newfd; regalloc ppf (round + 1) newfd + Reg.reinit(); Liveness.fundecl newfd; regalloc ~ppf_dump (round + 1) newfd end else newfd let (++) x f = f x -let compile_fundecl (ppf : formatter) fd_cmm = +let compile_fundecl ~ppf_dump fd_cmm = Proc.init (); Reg.reset(); fd_cmm ++ Profile.record ~accumulate:true "selection" Selection.fundecl - ++ pass_dump_if ppf dump_selection "After instruction selection" + ++ pass_dump_if ppf_dump dump_selection "After instruction selection" ++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl - ++ pass_dump_if ppf dump_combine "After allocation combining" + ++ pass_dump_if ppf_dump dump_combine "After allocation combining" ++ Profile.record ~accumulate:true "cse" CSE.fundecl - ++ pass_dump_if ppf dump_cse "After CSE" + ++ pass_dump_if ppf_dump dump_cse "After CSE" ++ Profile.record ~accumulate:true "liveness" liveness ++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl - ++ pass_dump_if ppf dump_live "Liveness analysis" + ++ pass_dump_if ppf_dump dump_live "Liveness analysis" ++ Profile.record ~accumulate:true "spill" Spill.fundecl ++ Profile.record ~accumulate:true "liveness" liveness - ++ pass_dump_if ppf dump_spill "After spilling" + ++ pass_dump_if ppf_dump dump_spill "After spilling" ++ Profile.record ~accumulate:true "split" Split.fundecl - ++ pass_dump_if ppf dump_split "After live range splitting" + ++ pass_dump_if ppf_dump dump_split "After live range splitting" ++ Profile.record ~accumulate:true "liveness" liveness - ++ Profile.record ~accumulate:true "regalloc" (regalloc ppf 1) + ++ Profile.record ~accumulate:true "regalloc" (regalloc ~ppf_dump 1) ++ Profile.record ~accumulate:true "available_regs" Available_regs.fundecl ++ Profile.record ~accumulate:true "linearize" Linearize.fundecl - ++ pass_dump_linear_if ppf dump_linear "Linearized code" + ++ pass_dump_linear_if ppf_dump dump_linear "Linearized code" ++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl - ++ pass_dump_linear_if ppf dump_scheduling "After instruction scheduling" + ++ pass_dump_linear_if ppf_dump dump_scheduling "After instruction scheduling" ++ Profile.record ~accumulate:true "emit" Emit.fundecl -let compile_phrase ppf p = - if !dump_cmm then fprintf ppf "%a@." Printcmm.phrase p; +let compile_phrase ~ppf_dump p = + if !dump_cmm then fprintf ppf_dump "%a@." Printcmm.phrase p; match p with - | Cfunction fd -> compile_fundecl ppf fd + | Cfunction fd -> compile_fundecl ~ppf_dump fd | Cdata dl -> Emit.data dl (* For the native toplevel: generates generic functions unless they are already available in the process *) -let compile_genfuns ppf f = +let compile_genfuns ~ppf_dump f = List.iter (function | (Cfunction {fun_name = name}) as ph when f name -> - compile_phrase ppf ph + compile_phrase ~ppf_dump ph | _ -> ()) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) @@ -173,14 +173,14 @@ let set_export_info (ulambda, prealloc, structured_constants, export) = Compilenv.set_export_info export; (ulambda, prealloc, structured_constants) -let end_gen_implementation ?toplevel ppf +let end_gen_implementation ?toplevel ~ppf_dump (clambda:clambda_and_constants) = Emit.begin_assembly (); clambda - ++ Profile.record "cmm" Cmmgen.compunit - ++ Profile.record "compile_phrases" (List.iter (compile_phrase ppf)) + ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump) + ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) ++ (fun () -> ()); - (match toplevel with None -> () | Some f -> compile_genfuns ppf f); + (match toplevel with None -> () | Some f -> compile_genfuns ~ppf_dump f); (* We add explicit references to external primitive symbols. This is to ensure that the object files that define these symbols, @@ -188,26 +188,26 @@ let end_gen_implementation ?toplevel ppf This is important if a module that uses such a symbol is later dynlinked. *) - compile_phrase ppf + compile_phrase ~ppf_dump (Cmmgen.reference_symbols (List.filter (fun s -> s <> "" && s.[0] <> '%') (List.map Primitive.native_name !Translmod.primitive_declarations)) ); Emit.end_assembly () -let flambda_gen_implementation ?toplevel ~backend ppf +let flambda_gen_implementation ?toplevel ~backend ~ppf_dump (program:Flambda.program) = let export = Build_export_info.build_transient ~backend program in let (clambda, preallocated, constants) = Profile.record_call "backend" (fun () -> (program, export) ++ Flambda_to_clambda.convert - ++ flambda_raw_clambda_dump_if ppf + ++ flambda_raw_clambda_dump_if ppf_dump ++ (fun { Flambda_to_clambda. expr; preallocated_blocks; structured_constants; exported; } -> (* "init_code" following the name used in [Cmmgen.compunit_and_constants]. *) - Un_anf.apply expr ~what:"init_code", preallocated_blocks, + Un_anf.apply ~ppf_dump expr ~what:"init_code", preallocated_blocks, structured_constants, exported) ++ set_export_info) in @@ -218,10 +218,10 @@ let flambda_gen_implementation ?toplevel ~backend ppf definition }) (Symbol.Map.bindings constants) in - end_gen_implementation ?toplevel ppf + end_gen_implementation ?toplevel ~ppf_dump (clambda, preallocated, constants) -let lambda_gen_implementation ?toplevel ppf +let lambda_gen_implementation ?toplevel ~ppf_dump (lambda:Lambda.program) = let clambda = Closure.intro lambda.main_module_block_size lambda.code in let preallocated_block = @@ -235,11 +235,11 @@ let lambda_gen_implementation ?toplevel ppf let clambda_and_constants = clambda, [preallocated_block], [] in - raw_clambda_dump_if ppf clambda_and_constants; - end_gen_implementation ?toplevel ppf clambda_and_constants + raw_clambda_dump_if ppf_dump clambda_and_constants; + end_gen_implementation ?toplevel ~ppf_dump clambda_and_constants let compile_implementation_gen ?toplevel prefixname - ~required_globals ppf gen_implementation program = + ~required_globals ~ppf_dump gen_implementation program = let asmfile = if !keep_asm_file || !Emitaux.binary_backend_available then prefixname ^ ext_asm @@ -248,18 +248,18 @@ let compile_implementation_gen ?toplevel prefixname compile_unit prefixname asmfile !keep_asm_file (prefixname ^ ext_obj) (fun () -> Ident.Set.iter Compilenv.require_global required_globals; - gen_implementation ?toplevel ppf program) + gen_implementation ?toplevel ~ppf_dump program) let compile_implementation_clambda ?toplevel prefixname - ppf (program:Lambda.program) = + ~ppf_dump (program:Lambda.program) = compile_implementation_gen ?toplevel prefixname ~required_globals:program.Lambda.required_globals - ppf lambda_gen_implementation program + ~ppf_dump lambda_gen_implementation program let compile_implementation_flambda ?toplevel prefixname - ~required_globals ~backend ppf (program:Flambda.program) = + ~required_globals ~backend ~ppf_dump (program:Flambda.program) = compile_implementation_gen ?toplevel prefixname - ~required_globals ppf (flambda_gen_implementation ~backend) program + ~required_globals ~ppf_dump (flambda_gen_implementation ~backend) program (* Error report *) diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index e70ee5116df3..f2f4ccaef399 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -20,15 +20,15 @@ val compile_implementation_flambda : string -> required_globals:Ident.Set.t -> backend:(module Backend_intf.S) -> - Format.formatter -> Flambda.program -> unit + ppf_dump:Format.formatter -> Flambda.program -> unit val compile_implementation_clambda : ?toplevel:(string -> bool) -> string -> - Format.formatter -> Lambda.program -> unit + ppf_dump:Format.formatter -> Lambda.program -> unit val compile_phrase : - Format.formatter -> Cmm.phrase -> unit + ppf_dump:Format.formatter -> Cmm.phrase -> unit type error = Assembler_error of string exception Error of error diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index e115e1e56c50..b04ac737f35d 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -203,11 +203,12 @@ let scan_file obj_name tolink = match read_file obj_name with (* Second pass: generate the startup file and link it with everything else *) -let force_linking_of_startup ppf = - Asmgen.compile_phrase ppf (Cmm.Cdata ([Cmm.Csymbol_address "caml_startup"])) +let force_linking_of_startup ~ppf_dump = + Asmgen.compile_phrase ~ppf_dump + (Cmm.Cdata ([Cmm.Csymbol_address "caml_startup"])) -let make_startup_file ppf units_list = - let compile_phrase p = Asmgen.compile_phrase ppf p in +let make_startup_file ~ppf_dump units_list = + let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in Location.input_name := "caml_startup"; (* set name of "current" input *) Compilenv.reset "_startup"; (* set the name of the "current" compunit *) @@ -242,11 +243,11 @@ let make_startup_file ppf units_list = compile_phrase (Cmmgen.spacetime_shapes all_names); end; if !Clflags.output_complete_object then - force_linking_of_startup ppf; + force_linking_of_startup ~ppf_dump; Emit.end_assembly () -let make_shared_startup_file ppf units = - let compile_phrase p = Asmgen.compile_phrase ppf p in +let make_shared_startup_file ~ppf_dump units = + let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in Location.input_name := "caml_startup"; Compilenv.reset "_shared_startup"; Emit.begin_assembly (); @@ -257,7 +258,7 @@ let make_shared_startup_file ppf units = (Cmmgen.global_table (List.map (fun (ui,_) -> ui.ui_symbol) units)); if !Clflags.output_complete_object then - force_linking_of_startup ppf; + force_linking_of_startup ~ppf_dump; (* this is to force a reference to all units, otherwise the linker might drop some of them (in case of libraries) *) Emit.end_assembly () @@ -266,7 +267,7 @@ let call_linker_shared file_list output_name = if not (Ccomp.call_linker Ccomp.Dll output_name file_list "") then raise(Error Linking_error) -let link_shared ppf objfiles output_name = +let link_shared ~ppf_dump objfiles output_name = Profile.record_call output_name (fun () -> let units_tolink = List.fold_right scan_file objfiles [] in List.iter @@ -285,7 +286,7 @@ let link_shared ppf objfiles output_name = Asmgen.compile_unit output_name startup !Clflags.keep_startup_file startup_obj (fun () -> - make_shared_startup_file ppf + make_shared_startup_file ~ppf_dump (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) ); call_linker_shared (startup_obj :: objfiles) output_name; @@ -321,7 +322,7 @@ let call_linker file_list startup_file output_name = (* Main entry point *) -let link ppf objfiles output_name = +let link ~ppf_dump objfiles output_name = Profile.record_call output_name (fun () -> let stdlib = if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in @@ -350,7 +351,7 @@ let link ppf objfiles output_name = let startup_obj = Filename.temp_file "camlstartup" ext_obj in Asmgen.compile_unit output_name startup !Clflags.keep_startup_file startup_obj - (fun () -> make_startup_file ppf units_tolink); + (fun () -> make_startup_file ~ppf_dump units_tolink); Misc.try_finally (fun () -> call_linker (List.map object_file_name objfiles) diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 55310bd901a1..80d66099040c 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -17,9 +17,9 @@ open Format -val link: formatter -> string list -> string -> unit +val link: ppf_dump:formatter -> string list -> string -> unit -val link_shared: formatter -> string list -> string -> unit +val link_shared: ppf_dump:formatter -> string list -> string -> unit val call_linker_shared: string list -> string -> unit diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 5a8c27944b61..f5b14f4f5f12 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -79,7 +79,7 @@ let check_units members = (* Make the .o file for the package *) -let make_package_object ppf members targetobj targetname coercion +let make_package_object ~ppf_dump members targetobj targetname coercion ~backend = Profile.record_call (Printf.sprintf "pack(%s)" targetname) (fun () -> let objtemp = @@ -102,7 +102,7 @@ let make_package_object ppf members targetobj targetname coercion if Config.flambda then begin let size, lam = Translmod.transl_package_flambda components coercion in let flam = - Middle_end.middle_end ppf + Middle_end.middle_end ~ppf_dump ~prefixname ~backend ~size @@ -111,13 +111,13 @@ let make_package_object ppf members targetobj targetname coercion ~module_initializer:lam in Asmgen.compile_implementation_flambda - prefixname ~backend ~required_globals:Ident.Set.empty ppf flam; + prefixname ~backend ~required_globals:Ident.Set.empty ~ppf_dump flam; end else begin let main_module_block_size, code = Translmod.transl_store_package components (Ident.create_persistent targetname) coercion in Asmgen.compile_implementation_clambda - prefixname ppf { Lambda.code; main_module_block_size; + prefixname ~ppf_dump { Lambda.code; main_module_block_size; module_ident; required_globals = Ident.Set.empty } end; let objfiles = @@ -220,7 +220,7 @@ let build_package_cmx members cmxfile = (* Make the .cmx and the .o for the package *) -let package_object_files ppf files targetcmx +let package_object_files ~ppf_dump files targetcmx targetobj targetname coercion ~backend = let pack_path = match !Clflags.for_package with @@ -228,12 +228,12 @@ let package_object_files ppf files targetcmx | Some p -> p ^ "." ^ targetname in let members = map_left_right (read_member_info pack_path) files in check_units members; - make_package_object ppf members targetobj targetname coercion ~backend; + make_package_object ~ppf_dump members targetobj targetname coercion ~backend; build_package_cmx members targetcmx (* The entry point *) -let package_files ppf initial_env files targetcmx ~backend = +let package_files ~ppf_dump initial_env files targetcmx ~backend = let files = List.map (fun f -> @@ -251,7 +251,7 @@ let package_files ppf initial_env files targetcmx ~backend = try let coercion = Typemod.package_units initial_env files targetcmi targetname in - package_object_files ppf files targetcmx targetobj targetname coercion + package_object_files ~ppf_dump files targetcmx targetobj targetname coercion ~backend with x -> remove_file targetcmx; remove_file targetobj; diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli index 203fc301ea0e..3ea2142540dd 100644 --- a/asmcomp/asmpackager.mli +++ b/asmcomp/asmpackager.mli @@ -17,7 +17,7 @@ original compilation units as sub-modules. *) val package_files - : Format.formatter + : ppf_dump:Format.formatter -> Env.t -> string list -> string diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 0738ef71b055..3c2d0599e79d 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -2821,10 +2821,10 @@ and transl_letrec env bindings cont = (* Translate a function definition *) -let transl_function f = +let transl_function ~ppf_dump f = let body = if Config.flambda then - Un_anf.apply f.body ~what:f.label + Un_anf.apply ~ppf_dump f.body ~what:f.label else f.body in @@ -2848,15 +2848,15 @@ let transl_function f = (* Translate all function definitions *) -let rec transl_all_functions already_translated cont = +let rec transl_all_functions ~ppf_dump already_translated cont = try let f = Queue.take functions in if String.Set.mem f.label already_translated then - transl_all_functions already_translated cont + transl_all_functions ~ppf_dump already_translated cont else begin - transl_all_functions + transl_all_functions ~ppf_dump (String.Set.add f.label already_translated) - ((f.dbg, transl_function f) :: cont) + ((f.dbg, transl_function ~ppf_dump f) :: cont) end with Queue.Empty -> cont, already_translated @@ -3016,14 +3016,14 @@ let emit_all_constants cont = Compilenv.clear_structured_constants (); emit_constants cont constants -let transl_all_functions_and_emit_all_constants cont = +let transl_all_functions_and_emit_all_constants ~ppf_dump cont = let rec aux already_translated cont translated_functions = if Compilenv.structured_constants () = [] && Queue.is_empty functions then cont, translated_functions else let translated_functions, already_translated = - transl_all_functions already_translated translated_functions + transl_all_functions ~ppf_dump already_translated translated_functions in let cont = emit_all_constants cont in aux already_translated cont translated_functions @@ -3088,7 +3088,7 @@ let emit_preallocated_blocks preallocated_blocks cont = (* Translate a compilation unit *) -let compunit (ulam, preallocated_blocks, constants) = +let compunit ~ppf_dump (ulam, preallocated_blocks, constants) = let init_code = if !Clflags.afl_instrument then Afl_instrument.instrument_initialiser (transl empty_env ulam) @@ -3108,7 +3108,7 @@ let compunit (ulam, preallocated_blocks, constants) = else [ Reduce_code_size ]; fun_dbg = Debuginfo.none }] in let c2 = emit_constants c1 constants in - let c3 = transl_all_functions_and_emit_all_constants c2 in + let c3 = transl_all_functions_and_emit_all_constants ~ppf_dump c2 in emit_preallocated_blocks preallocated_blocks c3 (* diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 8104afabea7a..550ac77a5460 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -16,7 +16,8 @@ (* Translation from closed lambda to C-- *) val compunit: - Clambda.ulambda + ppf_dump:Format.formatter + -> Clambda.ulambda * Clambda.preallocated_block list * Clambda.preallocated_constant list -> Cmm.phrase list diff --git a/asmcomp/un_anf.ml b/asmcomp/un_anf.ml index bc8f9eb8146a..2094a0ccf050 100644 --- a/asmcomp/un_anf.ml +++ b/asmcomp/un_anf.ml @@ -734,7 +734,7 @@ and un_anf_list ident_info env clams : Clambda.ulambda list = and un_anf_array ident_info env clams : Clambda.ulambda array = Array.map (un_anf ident_info env) clams -let apply clam ~what = +let apply ~ppf_dump clam ~what = let ident_info = make_ident_info clam in let let_bound_vars_that_can_be_moved = let_bound_vars_that_can_be_moved ident_info clam @@ -746,6 +746,7 @@ let apply clam ~what = let ident_info = make_ident_info clam in let clam = un_anf ident_info Ident.Map.empty clam in if !Clflags.dump_clambda then begin - Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam + Format.fprintf ppf_dump + "@.un-anf (%s):@ %a@." what Printclambda.clambda clam end; clam diff --git a/asmcomp/un_anf.mli b/asmcomp/un_anf.mli index 004704da2a0c..92ea06cd033e 100644 --- a/asmcomp/un_anf.mli +++ b/asmcomp/un_anf.mli @@ -17,6 +17,7 @@ (** Expand ANF-like constructs so that pattern matches in [Cmmgen] will work correctly. *) val apply - : Clambda.ulambda + : ppf_dump:Format.formatter + -> Clambda.ulambda -> what:string -> Clambda.ulambda diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index c6c38a9b49c0..e8c6d7fa4709 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -184,7 +184,7 @@ let rec rename_append_bytecode_list packagename oc mapping defined ofs (* Generate the code that builds the tuple representing the package module *) -let build_global_target oc target_name members mapping pos coercion = +let build_global_target ~ppf_dump oc target_name members mapping pos coercion = let components = List.map2 (fun m (_id1, id2) -> @@ -196,7 +196,7 @@ let build_global_target oc target_name members mapping pos coercion = Translmod.transl_package components (Ident.create_persistent target_name) coercion in if !Clflags.dump_lambda then - Format.printf "%a@." Printlambda.lambda lam; + Format.fprintf ppf_dump "%a@." Printlambda.lambda lam; let instrs = Bytegen.compile_implementation target_name lam in let rel = @@ -205,7 +205,7 @@ let build_global_target oc target_name members mapping pos coercion = (* Build the .cmo file obtained by packaging the given .cmo files. *) -let package_object_files files targetfile targetname coercion = +let package_object_files ~ppf_dump files targetfile targetname coercion = let members = map_left_right read_member_info files in let required_globals = @@ -242,7 +242,7 @@ let package_object_files files targetfile targetname coercion = let pos_code = pos_out oc in let ofs = rename_append_bytecode_list targetname oc mapping [] 0 targetname Subst.identity members in - build_global_target oc targetname members mapping ofs coercion; + build_global_target ~ppf_dump oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then begin output_value oc (List.rev !events); @@ -277,7 +277,7 @@ let package_object_files files targetfile targetname coercion = (* The entry point *) -let package_files initial_env files targetfile = +let package_files ~ppf_dump initial_env files targetfile = let files = List.map (fun f -> @@ -290,7 +290,7 @@ let package_files initial_env files targetfile = try let coercion = Typemod.package_units initial_env files targetcmi targetname in - package_object_files files targetfile targetname coercion + package_object_files ~ppf_dump files targetfile targetname coercion with x -> remove_file targetfile; raise x diff --git a/bytecomp/bytepackager.mli b/bytecomp/bytepackager.mli index ae8663a67db4..95177716b342 100644 --- a/bytecomp/bytepackager.mli +++ b/bytecomp/bytepackager.mli @@ -16,7 +16,8 @@ (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) -val package_files: Env.t -> string list -> string -> unit +val package_files: + ppf_dump:Format.formatter -> Env.t -> string list -> string -> unit type error = Forward_reference of string * Ident.t diff --git a/driver/compenv.ml b/driver/compenv.ml index 738d3b851f91..634e64c18c21 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -76,13 +76,13 @@ let is_unit_name name = with Exit -> false ;; -let check_unit_name ppf filename name = +let check_unit_name filename name = if not (is_unit_name name) then - Location.print_warning (Location.in_file filename) ppf + Location.prerr_warning (Location.in_file filename) (Warnings.Bad_module_name name);; (* Compute name of module from output file name *) -let module_of_filename ppf inputfile outputprefix = +let module_of_filename inputfile outputprefix = let basename = Filename.basename outputprefix in let name = try @@ -91,7 +91,7 @@ let module_of_filename ppf inputfile outputprefix = with Not_found -> basename in let name = String.capitalize_ascii name in - check_unit_name ppf inputfile name; + check_unit_name inputfile name; name ;; @@ -576,12 +576,12 @@ let process_action | ProcessImplementation name -> readenv ppf (Before_compile name); let opref = output_prefix name in - implementation ppf name opref; + implementation name opref; objfiles := (opref ^ ocaml_mod_ext) :: !objfiles | ProcessInterface name -> readenv ppf (Before_compile name); let opref = output_prefix name in - interface ppf name opref; + interface name opref; if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles | ProcessCFile name -> readenv ppf (Before_compile name); diff --git a/driver/compenv.mli b/driver/compenv.mli index d802bb079c4a..7063f996a83d 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -13,7 +13,7 @@ (* *) (**************************************************************************) -val module_of_filename : Format.formatter -> string -> string -> string +val module_of_filename : string -> string -> string val output_prefix : string -> string val extract_output : string option -> string @@ -49,7 +49,7 @@ val readenv : Format.formatter -> readenv_position -> unit val is_unit_name : string -> bool (* [check_unit_name ppf filename name] prints a warning in [filename] on [ppf] if [name] should not be used as a module name. *) -val check_unit_name : Format.formatter -> string -> string -> unit +val check_unit_name : string -> string -> unit (* Deferred actions of the compiler, while parsing arguments *) @@ -70,8 +70,8 @@ val intf : string -> unit val process_deferred_actions : Format.formatter * - (Format.formatter -> string -> string -> unit) * (* compile implementation *) - (Format.formatter -> string -> string -> unit) * (* compile interface *) + (string -> string -> unit) * (* compile implementation *) + (string -> string -> unit) * (* compile interface *) string * (* ocaml module extension *) string -> (* ocaml library extension *) unit diff --git a/driver/compile.ml b/driver/compile.ml index 7e472bd324a2..3d6e6a667d24 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -26,20 +26,23 @@ open Compenv let tool_name = "ocamlc" -let interface ppf sourcefile outputprefix = +let interface sourcefile outputprefix = + Compmisc.with_dump_ppf ~fileprefix:(outputprefix ^ ".cmi") (fun ppf_dump -> Profile.record_call sourcefile (fun () -> Compmisc.init_path false; - let modulename = module_of_filename ppf sourcefile outputprefix in + let modulename = module_of_filename sourcefile outputprefix in Env.set_unit_name modulename; let initial_env = Compmisc.initial_env () in let ast = Pparse.parse_interface ~tool_name sourcefile in - if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; - if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; + if !Clflags.dump_parsetree then + fprintf ppf_dump "%a@." Printast.interface ast; + if !Clflags.dump_source then + fprintf ppf_dump "%a@." Pprintast.signature ast; Profile.(record_call typing) (fun () -> let tsg = Typemod.type_interface sourcefile initial_env ast in if !Clflags.dump_typedtree then - fprintf ppf "%a@." Printtyped.interface tsg; + fprintf ppf_dump "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in if !Clflags.print_types then Printtyp.wrap_printing_env ~error:false initial_env (fun () -> @@ -58,7 +61,7 @@ let interface ppf sourcefile outputprefix = initial_env sg ; end ) - ) + )) (* Compile a .ml file *) @@ -68,20 +71,21 @@ let print_if ppf flag printer arg = let (++) x f = f x -let implementation ppf sourcefile outputprefix = +let implementation sourcefile outputprefix = + Compmisc.with_dump_ppf ~fileprefix:(outputprefix ^ ".cmo") (fun ppf_dump -> Profile.record_call sourcefile (fun () -> Compmisc.init_path false; - let modulename = module_of_filename ppf sourcefile outputprefix in + let modulename = module_of_filename sourcefile outputprefix in Env.set_unit_name modulename; let env = Compmisc.initial_env() in try let (typedtree, coercion) = Pparse.parse_implementation ~tool_name sourcefile - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ print_if ppf Clflags.dump_source Pprintast.structure + ++ print_if ppf_dump Clflags.dump_parsetree Printast.implementation + ++ print_if ppf_dump Clflags.dump_source Pprintast.structure ++ Profile.(record typing) (Typemod.type_implementation sourcefile outputprefix modulename env) - ++ print_if ppf Clflags.dump_typedtree + ++ print_if ppf_dump Clflags.dump_typedtree Printtyped.implementation_with_coercion in if !Clflags.print_types then begin @@ -94,11 +98,12 @@ let implementation ppf sourcefile outputprefix = (Translmod.transl_implementation modulename) ++ Profile.(record ~accumulate:true generate) (fun { Lambda.code = lambda; required_globals } -> - print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda + lambda + ++ print_if ppf_dump Clflags.dump_rawlambda Printlambda.lambda ++ Simplif.simplify_lambda sourcefile - ++ print_if ppf Clflags.dump_lambda Printlambda.lambda + ++ print_if ppf_dump Clflags.dump_lambda Printlambda.lambda ++ Bytegen.compile_implementation modulename - ++ print_if ppf Clflags.dump_instr Printinstr.instrlist + ++ print_if ppf_dump Clflags.dump_instr Printinstr.instrlist ++ fun bytecode -> bytecode, required_globals) in let objfile = outputprefix ^ ".cmo" in @@ -118,4 +123,4 @@ let implementation ppf sourcefile outputprefix = with x -> Stypes.dump (Some (outputprefix ^ ".annot")); raise x - ) + )) diff --git a/driver/compile.mli b/driver/compile.mli index defc101be3fc..61f342aea681 100644 --- a/driver/compile.mli +++ b/driver/compile.mli @@ -15,7 +15,5 @@ (* Compile a .ml or .mli file *) -open Format - -val interface: formatter -> string -> string -> unit -val implementation: formatter -> string -> string -> unit +val interface: string -> string -> unit +val implementation: string -> string -> unit diff --git a/driver/compmisc.ml b/driver/compmisc.ml index 2869db0d4364..81ff3619f8b2 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -70,3 +70,17 @@ let read_color_env () = | Some _ -> () with Not_found -> () + +let with_dump_ppf ~fileprefix f = + let ppf_dump, finally = + if not !Clflags.dump_into_file + then Format.err_formatter, ignore + else + let ch = open_out (fileprefix ^ ".dump") in + let ppf = Format.formatter_of_out_channel ch in + ppf, + (fun () -> + Format.pp_print_flush ppf (); + close_out ch) + in + Misc.try_finally (fun () -> f ppf_dump) finally diff --git a/driver/compmisc.mli b/driver/compmisc.mli index fb29ff57c128..6424bd676962 100644 --- a/driver/compmisc.mli +++ b/driver/compmisc.mli @@ -17,3 +17,5 @@ val init_path : ?dir:string -> bool -> unit val initial_env : unit -> Env.t val read_color_env : unit -> unit + +val with_dump_ppf : fileprefix:string -> (Format.formatter -> unit) -> unit diff --git a/driver/main.ml b/driver/main.ml index fd4c3c2b205b..0f1c541ce002 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -108,6 +108,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _verbose = set verbose let _nopervasives = set nopervasives let _match_context_rows n = match_context_rows := n + let _dump_into_file = set dump_into_file let _dno_unique_ids = unset unique_ids let _dunique_ids = set unique_ids let _dsource = set dump_source @@ -151,8 +152,9 @@ let main () = end; readenv ppf Before_link; if - List.length (List.filter (fun x -> !x) - [make_archive;make_package;compile_only;output_c_object]) + List.length + (List.filter (fun x -> !x) + [make_archive;make_package;compile_only;output_c_object]) > 1 then if !print_types then @@ -162,16 +164,18 @@ let main () = if !make_archive then begin Compmisc.init_path false; - Bytelibrarian.create_archive (Compenv.get_objfiles ~with_ocamlparam:false) - (extract_output !output_name); + Bytelibrarian.create_archive + (Compenv.get_objfiles ~with_ocamlparam:false) + (extract_output !output_name); Warnings.check_fatal (); end else if !make_package then begin Compmisc.init_path false; let extracted_output = extract_output !output_name in let revd = get_objfiles ~with_ocamlparam:false in - Bytepackager.package_files (Compmisc.initial_env ()) - revd (extracted_output); + Compmisc.with_dump_ppf ~fileprefix:extracted_output (fun ppf_dump -> + Bytepackager.package_files ~ppf_dump (Compmisc.initial_env ()) + revd (extracted_output)); Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin diff --git a/driver/main_args.ml b/driver/main_args.ml index 2fc432ff2ca9..792cdaaba64b 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -614,6 +614,10 @@ let mk_use_prims f = "-use-prims", Arg.String f, " (undocumented)" ;; +let mk_dump_into_file f = + "-dump-into-file", Arg.Unit f, " dump output like -dlambda into .dump" +;; + let mk_dparsetree f = "-dparsetree", Arg.Unit f, " (undocumented)" ;; @@ -895,6 +899,7 @@ module type Compiler_options = sig val _match_context_rows : int -> unit val _dtimings : unit -> unit val _dprofile : unit -> unit + val _dump_into_file : unit -> unit val _args: string -> string array val _args0: string -> string array @@ -1131,6 +1136,7 @@ struct mk_dcamlprimc F._dcamlprimc; mk_dtimings F._dtimings; mk_dprofile F._dprofile; + mk_dump_into_file F._dump_into_file; mk_args F._args; mk_args0 F._args0; @@ -1333,6 +1339,7 @@ struct mk_dstartup F._dstartup; mk_dtimings F._dtimings; mk_dprofile F._dprofile; + mk_dump_into_file F._dump_into_file; mk_dump_pass F._dump_pass; mk_args F._args; diff --git a/driver/main_args.mli b/driver/main_args.mli index d41f5df422cc..ded5b50a59ce 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -105,6 +105,7 @@ module type Compiler_options = sig val _match_context_rows : int -> unit val _dtimings : unit -> unit val _dprofile : unit -> unit + val _dump_into_file : unit -> unit val _args: string -> string array val _args0: string -> string array diff --git a/driver/optcompile.ml b/driver/optcompile.ml index a653f23b9eb7..566d919a104b 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -27,19 +27,22 @@ open Compenv let tool_name = "ocamlopt" -let interface ppf sourcefile outputprefix = +let interface sourcefile outputprefix = + Compmisc.with_dump_ppf ~fileprefix:(outputprefix ^ ".cmi") (fun ppf_dump -> Profile.record_call sourcefile (fun () -> Compmisc.init_path false; - let modulename = module_of_filename ppf sourcefile outputprefix in + let modulename = module_of_filename sourcefile outputprefix in Env.set_unit_name modulename; let initial_env = Compmisc.initial_env () in let ast = Pparse.parse_interface ~tool_name sourcefile in - if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast; - if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast; + if !Clflags.dump_parsetree then + fprintf ppf_dump "%a@." Printast.interface ast; + if !Clflags.dump_source then + fprintf ppf_dump "%a@." Pprintast.signature ast; Profile.(record_call typing) (fun () -> let tsg = Typemod.type_interface sourcefile initial_env ast in if !Clflags.dump_typedtree then - fprintf ppf "%a@." Printtyped.interface tsg; + fprintf ppf_dump "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in if !Clflags.print_types then Printtyp.wrap_printing_env ~error:false initial_env (fun () -> @@ -58,7 +61,7 @@ let interface ppf sourcefile outputprefix = initial_env sg ; end ) - ) + )) (* Compile a .ml file *) @@ -69,10 +72,11 @@ let print_if ppf flag printer arg = let (++) x f = f x let (+++) (x, y) f = (x, f y) -let implementation ~backend ppf sourcefile outputprefix = +let implementation ~backend sourcefile outputprefix = + Compmisc.with_dump_ppf ~fileprefix:(outputprefix ^ ".cmx") (fun ppf_dump -> Profile.record_call sourcefile (fun () -> Compmisc.init_path true; - let modulename = module_of_filename ppf sourcefile outputprefix in + let modulename = module_of_filename sourcefile outputprefix in Env.set_unit_name modulename; let env = Compmisc.initial_env() in Compilenv.reset ?packname:!Clflags.for_package modulename; @@ -81,11 +85,11 @@ let implementation ~backend ppf sourcefile outputprefix = let comp ast = let (typedtree, coercion) = ast - ++ print_if ppf Clflags.dump_parsetree Printast.implementation - ++ print_if ppf Clflags.dump_source Pprintast.structure + ++ print_if ppf_dump Clflags.dump_parsetree Printast.implementation + ++ print_if ppf_dump Clflags.dump_source Pprintast.structure ++ Profile.(record typing) (Typemod.type_implementation sourcefile outputprefix modulename env) - ++ print_if ppf Clflags.dump_typedtree + ++ print_if ppf_dump Clflags.dump_typedtree Printtyped.implementation_with_coercion in if not !Clflags.print_types then begin @@ -103,19 +107,19 @@ let implementation ~backend ppf sourcefile outputprefix = (fun { Lambda.module_ident; main_module_block_size; required_globals; code } -> ((module_ident, main_module_block_size), code) - +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda + +++ print_if ppf_dump Clflags.dump_rawlambda Printlambda.lambda +++ Simplif.simplify_lambda sourcefile - +++ print_if ppf Clflags.dump_lambda Printlambda.lambda + +++ print_if ppf_dump Clflags.dump_lambda Printlambda.lambda ++ (fun ((module_ident, size), lam) -> - Middle_end.middle_end ppf + Middle_end.middle_end ~ppf_dump ~prefixname:outputprefix ~size ~filename:sourcefile ~module_ident ~backend ~module_initializer:lam) - ++ Asmgen.compile_implementation_flambda - outputprefix ~required_globals ~backend ppf; + ++ Asmgen.compile_implementation_flambda ~ppf_dump + outputprefix ~required_globals ~backend; Compilenv.save_unit_info cmxfile) end else begin @@ -123,15 +127,14 @@ let implementation ~backend ppf sourcefile outputprefix = (typedtree, coercion) ++ Profile.(record transl) (Translmod.transl_store_implementation modulename) - ++ print_if ppf Clflags.dump_rawlambda Printlambda.program + ++ print_if ppf_dump Clflags.dump_rawlambda Printlambda.program ++ Profile.(record generate) (fun program -> { program with Lambda.code = Simplif.simplify_lambda sourcefile program.Lambda.code } - ++ print_if ppf Clflags.dump_lambda Printlambda.program - ++ Asmgen.compile_implementation_clambda - outputprefix ppf; + ++ print_if ppf_dump Clflags.dump_lambda Printlambda.program + ++ Asmgen.compile_implementation_clambda ~ppf_dump outputprefix; Compilenv.save_unit_info cmxfile) end end; @@ -144,4 +147,4 @@ let implementation ~backend ppf sourcefile outputprefix = remove_file objfile; remove_file cmxfile; raise x - ) + )) diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 3f3081383d99..3bdd2554dd54 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -15,13 +15,10 @@ (* Compile a .ml or .mli file *) -open Format - -val interface: formatter -> string -> string -> unit +val interface: string -> string -> unit val implementation: backend:(module Backend_intf.S) - -> formatter -> string -> string -> unit diff --git a/driver/optmain.ml b/driver/optmain.ml index 0aa496971376..0fc8a5daeb48 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -192,6 +192,7 @@ module Options = Main_args.Make_optcomp_options (struct let _nopervasives = set nopervasives let _match_context_rows n = match_context_rows := n + let _dump_into_file = set dump_into_file let _dno_unique_ids = clear unique_ids let _dunique_ids = set unique_ids let _dsource = set dump_source @@ -270,24 +271,29 @@ let main () = [make_package; make_archive; shared; compile_only; output_c_object]) > 1 then - fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj"; + fatal "Please specify at most one of -pack, -a, -shared, -c, \ + -output-obj"; if !make_archive then begin Compmisc.init_path true; let target = extract_output !output_name in - Asmlibrarian.create_archive (get_objfiles ~with_ocamlparam:false) target; + Asmlibrarian.create_archive + (get_objfiles ~with_ocamlparam:false) target; Warnings.check_fatal (); end else if !make_package then begin Compmisc.init_path true; let target = extract_output !output_name in - Asmpackager.package_files ppf (Compmisc.initial_env ()) - (get_objfiles ~with_ocamlparam:false) target ~backend; + Compmisc.with_dump_ppf ~fileprefix:target (fun ppf_dump -> + Asmpackager.package_files ~ppf_dump (Compmisc.initial_env ()) + (get_objfiles ~with_ocamlparam:false) target ~backend); Warnings.check_fatal (); end else if !shared then begin Compmisc.init_path true; let target = extract_output !output_name in - Asmlink.link_shared ppf (get_objfiles ~with_ocamlparam:false) target; + Compmisc.with_dump_ppf ~fileprefix:target (fun ppf_dump -> + Asmlink.link_shared ~ppf_dump + (get_objfiles ~with_ocamlparam:false) target); Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin @@ -307,7 +313,8 @@ let main () = default_output !output_name in Compmisc.init_path true; - Asmlink.link ppf (get_objfiles ~with_ocamlparam:true) target; + Compmisc.with_dump_ppf ~fileprefix:target (fun ppf_dump -> + Asmlink.link ~ppf_dump (get_objfiles ~with_ocamlparam:true) target); Warnings.check_fatal (); end; with x -> diff --git a/middle_end/augment_specialised_args.ml b/middle_end/augment_specialised_args.ml index aba2965785ef..1cefa295e245 100755 --- a/middle_end/augment_specialised_args.ml +++ b/middle_end/augment_specialised_args.ml @@ -752,7 +752,8 @@ module Make (T : S) = struct Some (expr, benefit) let rewrite_set_of_closures ~env ~duplicate_function ~set_of_closures = - Pass_wrapper.with_dump ~pass_name:T.pass_name ~input:set_of_closures + Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) + ~pass_name:T.pass_name ~input:set_of_closures ~print_input:Flambda.print_set_of_closures ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) ~f:(fun () -> diff --git a/middle_end/inline_and_simplify.ml b/middle_end/inline_and_simplify.ml index e0af842aedb6..136854f6d81c 100755 --- a/middle_end/inline_and_simplify.ml +++ b/middle_end/inline_and_simplify.ml @@ -937,7 +937,8 @@ and simplify_named env r (tree : Flambda.named) : Flambda.named * R.t = the [Unbox_closures] output, this also prevents applying [Unbox_closures] over and over.) *) let set_of_closures = - match Remove_free_vars_equal_to_args.run set_of_closures with + let ppf_dump = Inline_and_simplify_aux.Env.ppf_dump env in + match Remove_free_vars_equal_to_args.run ~ppf_dump set_of_closures with | None -> set_of_closures | Some set_of_closures -> set_of_closures in @@ -1678,13 +1679,13 @@ let add_predef_exns_to_environment ~env ~backend = env Predef.all_predef_exns -let run ~never_inline ~backend ~prefixname ~round program = +let run ~never_inline ~backend ~prefixname ~round ~ppf_dump program = let r = R.create () in let report = !Clflags.inlining_report in if never_inline then Clflags.inlining_report := false; let initial_env = add_predef_exns_to_environment - ~env:(E.create ~never_inline ~backend ~round) + ~env:(E.create ~never_inline ~backend ~round ~ppf_dump) ~backend in let result, r = simplify_program initial_env r program in diff --git a/middle_end/inline_and_simplify.mli b/middle_end/inline_and_simplify.mli index ad0845e2be3d..9a8e6e8b46c1 100644 --- a/middle_end/inline_and_simplify.mli +++ b/middle_end/inline_and_simplify.mli @@ -27,6 +27,7 @@ val run -> backend:(module Backend_intf.S) -> prefixname:string -> round:int + -> ppf_dump:Format.formatter -> Flambda.program -> Flambda.program diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/inline_and_simplify_aux.ml index e3d22a894536..fd2bb232d73e 100644 --- a/middle_end/inline_and_simplify_aux.ml +++ b/middle_end/inline_and_simplify_aux.ml @@ -23,6 +23,7 @@ module Env = struct type t = { backend : (module Backend_intf.S); round : int; + ppf_dump : Format.formatter; approx : (scope * Simple_value_approx.t) Variable.Map.t; approx_mutable : Simple_value_approx.t Mutable_variable.Map.t; approx_sym : Simple_value_approx.t Symbol.Map.t; @@ -45,9 +46,10 @@ module Env = struct inlined_debuginfo : Debuginfo.t; } - let create ~never_inline ~backend ~round = + let create ~never_inline ~backend ~round ~ppf_dump = { backend; round; + ppf_dump; approx = Variable.Map.empty; approx_mutable = Mutable_variable.Map.empty; approx_sym = Symbol.Map.empty; @@ -70,6 +72,7 @@ module Env = struct let backend t = t.backend let round t = t.round + let ppf_dump t = t.ppf_dump let local env = { env with diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/inline_and_simplify_aux.mli index 43619b2f24c4..79d84a31b821 100755 --- a/middle_end/inline_and_simplify_aux.mli +++ b/middle_end/inline_and_simplify_aux.mli @@ -33,6 +33,7 @@ module Env : sig : never_inline:bool -> backend:(module Backend_intf.S) -> round:int + -> ppf_dump:Format.formatter -> t (** Obtain the first-class module that gives information about the @@ -47,6 +48,9 @@ module Env : sig (** Which simplification round we are currently in. *) val round : t -> int + (** Where to print intermediate asts and similar debug information *) + val ppf_dump : t -> Format.formatter + (** Add the approximation of a variable---that is to say, some knowledge about the value(s) the variable may take on at runtime---to the environment. *) diff --git a/middle_end/middle_end.ml b/middle_end/middle_end.ml index b3461f18c3a0..25d6e530acb1 100644 --- a/middle_end/middle_end.ml +++ b/middle_end/middle_end.ml @@ -31,7 +31,7 @@ let _dump_function_sizes flam ~backend = | None -> assert false) set_of_closures.function_decls.funs) -let middle_end ppf ~prefixname ~backend +let middle_end ~ppf_dump ~prefixname ~backend ~size ~filename ~module_ident @@ -69,10 +69,10 @@ let middle_end ppf ~prefixname ~backend let (+-+) flam (name, pass) = incr pass_number; if !Clflags.dump_flambda_verbose then begin - Format.fprintf ppf "@.PASS: %s@." name; - Format.fprintf ppf "Before pass %d, round %d:@ %a@." !pass_number - !round_number Flambda.print_program flam; - Format.eprintf "\n@?" + Format.fprintf ppf_dump "@.PASS: %s@." name; + Format.fprintf ppf_dump "Before pass %d, round %d:@ %a@." + !pass_number !round_number Flambda.print_program flam; + Format.fprintf ppf_dump "\n@?" end; let flam = Profile.record ~accumulate:true name pass flam in if !Clflags.flambda_invariant_checks then begin @@ -90,7 +90,7 @@ let middle_end ppf ~prefixname ~backend in if !Clflags.dump_rawflambda then - Format.fprintf ppf "After closure conversion:@ %a@." + Format.fprintf ppf_dump "After closure conversion:@ %a@." Flambda.print_program flam; check flam; let fast_mode flam = @@ -104,7 +104,7 @@ let middle_end ppf ~prefixname ~backend Lift_let_to_initialize_symbol.lift ~backend) +-+ ("Inline_and_simplify", Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round) + ~prefixname ~round ~ppf_dump) +-+ ("Remove_unused_closure_vars 2", Remove_unused_closure_vars.remove_unused_closure_variables ~remove_direct_call_surrogates:false) @@ -135,14 +135,14 @@ let middle_end ppf ~prefixname ~backend ~remove_direct_call_surrogates:false) +-+ ("Inline_and_simplify", Inline_and_simplify.run ~never_inline:false ~backend - ~prefixname ~round) + ~prefixname ~round ~ppf_dump) +-+ ("Remove_unused_closure_vars 2", Remove_unused_closure_vars.remove_unused_closure_variables ~remove_direct_call_surrogates:false) +-+ ("lift_lets 3", Lift_code.lift_lets) +-+ ("Inline_and_simplify noinline", Inline_and_simplify.run ~never_inline:true ~backend - ~prefixname ~round) + ~prefixname ~round ~ppf_dump) +-+ ("Remove_unused_closure_vars 3", Remove_unused_closure_vars.remove_unused_closure_variables ~remove_direct_call_surrogates:false) @@ -191,7 +191,7 @@ let middle_end ppf ~prefixname ~backend was being applied)")); if !Clflags.dump_flambda then - Format.fprintf ppf "End of middle end:@ %a@." + Format.fprintf ppf_dump "End of middle end:@ %a@." Flambda.print_program flam; check flam; (* CR-someday mshinwell: add -d... option for this *) diff --git a/middle_end/middle_end.mli b/middle_end/middle_end.mli index 0f715b9d0b0c..584cb45a9891 100644 --- a/middle_end/middle_end.mli +++ b/middle_end/middle_end.mli @@ -19,7 +19,7 @@ (* Translate Lambda code to Flambda code and then optimize it. *) val middle_end - : Format.formatter + : ppf_dump:Format.formatter -> prefixname:string -> backend:(module Backend_intf.S) -> size:int diff --git a/middle_end/pass_wrapper.ml b/middle_end/pass_wrapper.ml index 9c9dad454d7b..c9930ae0c57e 100644 --- a/middle_end/pass_wrapper.ml +++ b/middle_end/pass_wrapper.ml @@ -20,16 +20,16 @@ open! Int_replace_polymorphic_compare let register ~pass_name = Clflags.all_passes := pass_name :: !Clflags.all_passes -let with_dump ~pass_name ~f ~input ~print_input ~print_output = +let with_dump ~ppf_dump ~pass_name ~f ~input ~print_input ~print_output = let dump = Clflags.dumped_pass pass_name in let result = f () in match result with | None -> - if dump then Format.eprintf "%s: no-op.\n\n%!" pass_name; + if dump then Format.fprintf ppf_dump "%s: no-op.\n\n%!" pass_name; None | Some result -> if dump then begin - Format.eprintf "Before %s:@ %a@.@." pass_name print_input input; - Format.eprintf "After %s:@ %a@.@." pass_name print_output result + Format.fprintf ppf_dump "Before %s:@ %a@.@." pass_name print_input input; + Format.fprintf ppf_dump "After %s:@ %a@.@." pass_name print_output result; end; Some result diff --git a/middle_end/pass_wrapper.mli b/middle_end/pass_wrapper.mli index a6d3bf9d55c2..3a30e61d6d97 100644 --- a/middle_end/pass_wrapper.mli +++ b/middle_end/pass_wrapper.mli @@ -17,7 +17,8 @@ val register : pass_name:string -> unit val with_dump - : pass_name:string + : ppf_dump:Format.formatter + -> pass_name:string -> f:(unit -> 'b option) -> input:'a -> print_input:(Format.formatter -> 'a -> unit) diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/remove_free_vars_equal_to_args.ml index 092f2de70e1d..aae3e47f10bc 100755 --- a/middle_end/remove_free_vars_equal_to_args.ml +++ b/middle_end/remove_free_vars_equal_to_args.ml @@ -92,8 +92,8 @@ let rewrite_one_set_of_closures (set_of_closures : Flambda.set_of_closures) = in Some set_of_closures -let run set_of_closures = - Pass_wrapper.with_dump ~pass_name ~input:set_of_closures +let run ~ppf_dump set_of_closures = + Pass_wrapper.with_dump ~ppf_dump ~pass_name ~input:set_of_closures ~print_input:Flambda.print_set_of_closures ~print_output:Flambda.print_set_of_closures ~f:(fun () -> rewrite_one_set_of_closures set_of_closures) diff --git a/middle_end/remove_free_vars_equal_to_args.mli b/middle_end/remove_free_vars_equal_to_args.mli index ae92d44da4f5..49f25ac10679 100644 --- a/middle_end/remove_free_vars_equal_to_args.mli +++ b/middle_end/remove_free_vars_equal_to_args.mli @@ -17,4 +17,7 @@ (** Replace free variables in closures known to be equal to specialised arguments of such closures with those specialised arguments. *) -val run : Flambda.set_of_closures -> Flambda.set_of_closures option +val run + : ppf_dump:Format.formatter + -> Flambda.set_of_closures + -> Flambda.set_of_closures option diff --git a/middle_end/unbox_free_vars_of_closures.ml b/middle_end/unbox_free_vars_of_closures.ml index d080c6ba7f45..6b753d76fc77 100644 --- a/middle_end/unbox_free_vars_of_closures.ml +++ b/middle_end/unbox_free_vars_of_closures.ml @@ -163,7 +163,8 @@ let run ~env ~(set_of_closures : Flambda.set_of_closures) = Some (expr, benefit) let run ~env ~set_of_closures = - Pass_wrapper.with_dump ~pass_name ~input:set_of_closures + Pass_wrapper.with_dump ~ppf_dump:(Inline_and_simplify_aux.Env.ppf_dump env) + ~pass_name ~input:set_of_closures ~print_input:Flambda.print_set_of_closures ~print_output:(fun ppf (expr, _) -> Flambda.print ppf expr) ~f:(fun () -> run ~env ~set_of_closures) diff --git a/testsuite/tools/codegen_main.ml b/testsuite/tools/codegen_main.ml index 8a4f45caacf2..52aa0c377ec6 100644 --- a/testsuite/tools/codegen_main.ml +++ b/testsuite/tools/codegen_main.ml @@ -28,8 +28,8 @@ let compile_file filename = lb.Lexing.lex_curr_p <- { lb.Lexing.lex_curr_p with pos_fname = filename }; try while true do - Asmgen.compile_phrase Format.std_formatter - (Parsecmm.phrase Lexcmm.token lb) + Asmgen.compile_phrase ~ppf_dump:Format.std_formatter + (Parsecmm.phrase Lexcmm.token lb) done with End_of_file -> diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 2e4a1b74302b..d113358c024f 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -123,6 +123,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _where = option "-where" let _nopervasives = option "-nopervasives" let _match_context_rows n = option_with_int "-match-context-rows" n + let _dump_into_file = option "-dump-into-file" let _dno_unique_ids = option "-dno-unique-ids" let _dunique_ids = option "-dunique-ids" let _dsource = option "-dsource" diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 04bb6ffda333..88b84c819ccd 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -148,6 +148,7 @@ module Options = Main_args.Make_optcomp_options (struct let _linscan = option "-linscan" let _nopervasives = option "-nopervasives" let _match_context_rows n = option_with_int "-match-context-rows" n + let _dump_into_file = option "-dump-into-file" let _dno_unique_ids = option "-dno-unique_ids" let _dunique_ids = option "-dunique_ids" let _dsource = option "-dsource" diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml index b4e03553ae3b..ff1335009049 100644 --- a/toplevel/opttopdirs.ml +++ b/toplevel/opttopdirs.ml @@ -72,7 +72,7 @@ let load_file ppf name0 = if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" then let cmxs = Filename.temp_file "caml" ".cmxs" in - Asmlink.link_shared ppf [name] cmxs; + Asmlink.link_shared ~ppf_dump:ppf [name] cmxs; cmxs,true else name,false diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 695dbe3a3a35..c4ae2f0f5199 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -221,13 +221,13 @@ let load_lambda ppf ~module_ident ~required_globals lam size = let fn = Filename.chop_extension dll in if not Config.flambda then Asmgen.compile_implementation_clambda - ~toplevel:need_symbol fn ppf + ~toplevel:need_symbol fn ~ppf_dump:ppf { Lambda.code=slam ; main_module_block_size=size; module_ident; required_globals } else Asmgen.compile_implementation_flambda - ~required_globals ~backend ~toplevel:need_symbol fn ppf - (Middle_end.middle_end ppf ~prefixname:"" ~backend ~size + ~required_globals ~backend ~toplevel:need_symbol fn ~ppf_dump:ppf + (Middle_end.middle_end ~ppf_dump:ppf ~prefixname:"" ~backend ~size ~module_ident ~module_initializer:slam ~filename:"toplevel"); Asmlink.call_linker_shared [fn ^ ext_obj] dll; Sys.remove (fn ^ ext_obj); diff --git a/utils/clflags.ml b/utils/clflags.ml index aadd8d933dfe..af942b62908a 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -365,6 +365,8 @@ let set_dumped_pass s enabled = dumped_passes_list := dumped_passes end +let dump_into_file = ref false (* -dump-into-file *) + let parse_color_setting = function | "auto" -> Some Misc.Color.Auto | "always" -> Some Misc.Color.Always diff --git a/utils/clflags.mli b/utils/clflags.mli index 891bb7be84d8..639ae5cc48e1 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -210,6 +210,8 @@ val all_passes : string list ref val dumped_pass : string -> bool val set_dumped_pass : string -> bool -> unit +val dump_into_file : bool ref + val parse_color_setting : string -> Misc.Color.setting option val color : Misc.Color.setting option ref