diff --git a/.depend b/.depend index 45473a40c..2bfa7362b 100644 --- a/.depend +++ b/.depend @@ -1916,9 +1916,7 @@ asmcomp/arch.cmx : \ utils/config.cmx \ utils/clflags.cmx asmcomp/asmgen.cmo : \ - middle_end/flambda/un_anf.cmi \ lambda/translmod.cmi \ - middle_end/symbol.cmi \ asmcomp/split.cmi \ asmcomp/spill.cmi \ asmcomp/selection.cmi \ @@ -1930,22 +1928,17 @@ asmcomp/asmgen.cmo : \ asmcomp/printmach.cmi \ asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi \ - middle_end/printclambda.cmi \ typing/primitive.cmi \ - typing/path.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ parsing/location.cmi \ asmcomp/liveness.cmi \ asmcomp/linscan.cmi \ - middle_end/linkage_name.cmi \ asmcomp/linearize.cmi \ lambda/lambda.cmi \ asmcomp/interval.cmi \ asmcomp/interf.cmi \ typing/ident.cmi \ - middle_end/flambda/flambda_to_clambda.cmi \ - middle_end/flambda/flambda.cmi \ asmcomp/emitaux.cmi \ asmcomp/emit.cmi \ asmcomp/deadcode.cmi \ @@ -1955,17 +1948,14 @@ asmcomp/asmgen.cmo : \ asmcomp/coloring.cmi \ asmcomp/cmmgen.cmi \ asmcomp/cmm.cmi \ - middle_end/closure/closure.cmi \ utils/clflags.cmi \ middle_end/clambda.cmi \ asmcomp/CSE.cmo \ - middle_end/flambda/build_export_info.cmi \ + middle_end/backend_intf.cmi \ asmcomp/debug/available_regs.cmi \ asmcomp/asmgen.cmi asmcomp/asmgen.cmx : \ - middle_end/flambda/un_anf.cmx \ lambda/translmod.cmx \ - middle_end/symbol.cmx \ asmcomp/split.cmx \ asmcomp/spill.cmx \ asmcomp/selection.cmx \ @@ -1977,22 +1967,17 @@ asmcomp/asmgen.cmx : \ asmcomp/printmach.cmx \ asmcomp/printlinear.cmx \ asmcomp/printcmm.cmx \ - middle_end/printclambda.cmx \ typing/primitive.cmx \ - typing/path.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ parsing/location.cmx \ asmcomp/liveness.cmx \ asmcomp/linscan.cmx \ - middle_end/linkage_name.cmx \ asmcomp/linearize.cmx \ lambda/lambda.cmx \ asmcomp/interval.cmx \ asmcomp/interf.cmx \ typing/ident.cmx \ - middle_end/flambda/flambda_to_clambda.cmx \ - middle_end/flambda/flambda.cmx \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ asmcomp/deadcode.cmx \ @@ -2002,18 +1987,16 @@ asmcomp/asmgen.cmx : \ asmcomp/coloring.cmx \ asmcomp/cmmgen.cmx \ asmcomp/cmm.cmx \ - middle_end/closure/closure.cmx \ utils/clflags.cmx \ middle_end/clambda.cmx \ asmcomp/CSE.cmx \ - middle_end/flambda/build_export_info.cmx \ + middle_end/backend_intf.cmi \ asmcomp/debug/available_regs.cmx \ asmcomp/asmgen.cmi asmcomp/asmgen.cmi : \ lambda/lambda.cmi \ - typing/ident.cmi \ - middle_end/flambda/flambda.cmi \ asmcomp/cmm.cmi \ + middle_end/clambda.cmi \ middle_end/backend_intf.cmi asmcomp/asmlibrarian.cmo : \ utils/misc.cmi \ @@ -2098,6 +2081,7 @@ asmcomp/asmpackager.cmo : \ middle_end/compilenv.cmi \ middle_end/compilation_unit.cmi \ file_formats/cmx_format.cmi \ + middle_end/closure/closure_middle_end.cmi \ utils/clflags.cmi \ utils/ccomp.cmi \ asmcomp/asmlink.cmi \ @@ -2120,6 +2104,7 @@ asmcomp/asmpackager.cmx : \ middle_end/compilenv.cmx \ middle_end/compilation_unit.cmx \ file_formats/cmx_format.cmi \ + middle_end/closure/closure_middle_end.cmx \ utils/clflags.cmx \ utils/ccomp.cmx \ asmcomp/asmlink.cmx \ @@ -3548,6 +3533,30 @@ middle_end/closure/closure.cmi : \ lambda/lambda.cmi \ middle_end/clambda.cmi \ middle_end/backend_intf.cmi +middle_end/closure/closure_middle_end.cmo : \ + middle_end/printclambda.cmi \ + typing/path.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + middle_end/compilenv.cmi \ + middle_end/closure/closure.cmi \ + utils/clflags.cmi \ + middle_end/clambda.cmi \ + middle_end/closure/closure_middle_end.cmi +middle_end/closure/closure_middle_end.cmx : \ + middle_end/printclambda.cmx \ + typing/path.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + middle_end/compilenv.cmx \ + middle_end/closure/closure.cmx \ + utils/clflags.cmx \ + middle_end/clambda.cmx \ + middle_end/closure/closure_middle_end.cmi +middle_end/closure/closure_middle_end.cmi : \ + lambda/lambda.cmi \ + middle_end/clambda.cmi \ + middle_end/backend_intf.cmi middle_end/flambda/alias_analysis.cmo : \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ @@ -4071,65 +4080,81 @@ middle_end/flambda/flambda_iterators.cmi : \ middle_end/flambda/flambda_middle_end.cmo : \ utils/warnings.cmi \ middle_end/variable.cmi \ + middle_end/flambda/un_anf.cmi \ middle_end/symbol.cmi \ middle_end/flambda/share_constants.cmi \ middle_end/flambda/remove_unused_program_constructs.cmi \ middle_end/flambda/remove_unused_closure_vars.cmi \ middle_end/flambda/ref_to_variables.cmi \ utils/profile.cmi \ + middle_end/printclambda.cmi \ utils/misc.cmi \ parsing/location.cmi \ + middle_end/linkage_name.cmi \ middle_end/flambda/lift_let_to_initialize_symbol.cmi \ middle_end/flambda/lift_constants.cmi \ middle_end/flambda/lift_code.cmi \ + lambda/lambda.cmi \ utils/int_replace_polymorphic_compare.cmi \ middle_end/flambda/inlining_cost.cmi \ middle_end/flambda/inline_and_simplify.cmi \ middle_end/flambda/initialize_symbol_to_let_symbol.cmi \ + middle_end/flambda/flambda_to_clambda.cmi \ middle_end/flambda/flambda_iterators.cmi \ middle_end/flambda/flambda_invariants.cmi \ middle_end/flambda/flambda.cmi \ lambda/debuginfo.cmi \ + middle_end/compilenv.cmi \ middle_end/flambda/base_types/closure_id.cmi \ middle_end/flambda/closure_conversion.cmi \ utils/clflags.cmi \ + middle_end/clambda.cmi \ + middle_end/flambda/build_export_info.cmi \ middle_end/backend_intf.cmi \ middle_end/flambda/flambda_middle_end.cmi middle_end/flambda/flambda_middle_end.cmx : \ utils/warnings.cmx \ middle_end/variable.cmx \ + middle_end/flambda/un_anf.cmx \ middle_end/symbol.cmx \ middle_end/flambda/share_constants.cmx \ middle_end/flambda/remove_unused_program_constructs.cmx \ middle_end/flambda/remove_unused_closure_vars.cmx \ middle_end/flambda/ref_to_variables.cmx \ utils/profile.cmx \ + middle_end/printclambda.cmx \ utils/misc.cmx \ parsing/location.cmx \ + middle_end/linkage_name.cmx \ middle_end/flambda/lift_let_to_initialize_symbol.cmx \ middle_end/flambda/lift_constants.cmx \ middle_end/flambda/lift_code.cmx \ + lambda/lambda.cmx \ utils/int_replace_polymorphic_compare.cmx \ middle_end/flambda/inlining_cost.cmx \ middle_end/flambda/inline_and_simplify.cmx \ middle_end/flambda/initialize_symbol_to_let_symbol.cmx \ + middle_end/flambda/flambda_to_clambda.cmx \ middle_end/flambda/flambda_iterators.cmx \ middle_end/flambda/flambda_invariants.cmx \ middle_end/flambda/flambda.cmx \ lambda/debuginfo.cmx \ + middle_end/compilenv.cmx \ middle_end/flambda/base_types/closure_id.cmx \ middle_end/flambda/closure_conversion.cmx \ utils/clflags.cmx \ + middle_end/clambda.cmx \ + middle_end/flambda/build_export_info.cmx \ middle_end/backend_intf.cmi \ middle_end/flambda/flambda_middle_end.cmi middle_end/flambda/flambda_middle_end.cmi : \ lambda/lambda.cmi \ - typing/ident.cmi \ - middle_end/flambda/flambda.cmi \ + middle_end/clambda.cmi \ middle_end/backend_intf.cmi middle_end/flambda/flambda_to_clambda.cmo : \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/flambda/un_anf.cmi \ middle_end/flambda/base_types/tag.cmi \ middle_end/symbol.cmi \ middle_end/flambda/base_types/static_exception.cmi \ @@ -4148,6 +4173,7 @@ middle_end/flambda/flambda_to_clambda.cmo : \ middle_end/flambda/export_info.cmi \ lambda/debuginfo.cmi \ middle_end/compilenv.cmi \ + middle_end/compilation_unit.cmi \ middle_end/flambda/closure_offsets.cmi \ middle_end/flambda/base_types/closure_id.cmi \ utils/clflags.cmi \ @@ -4158,6 +4184,7 @@ middle_end/flambda/flambda_to_clambda.cmo : \ middle_end/flambda/flambda_to_clambda.cmx : \ middle_end/variable.cmx \ middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/flambda/un_anf.cmx \ middle_end/flambda/base_types/tag.cmx \ middle_end/symbol.cmx \ middle_end/flambda/base_types/static_exception.cmx \ @@ -4176,6 +4203,7 @@ middle_end/flambda/flambda_to_clambda.cmx : \ middle_end/flambda/export_info.cmx \ lambda/debuginfo.cmx \ middle_end/compilenv.cmx \ + middle_end/compilation_unit.cmx \ middle_end/flambda/closure_offsets.cmx \ middle_end/flambda/base_types/closure_id.cmx \ utils/clflags.cmx \ @@ -5154,6 +5182,7 @@ middle_end/flambda/traverse_for_exported_symbols.cmi : \ middle_end/flambda/base_types/export_id.cmi \ middle_end/flambda/base_types/closure_id.cmi middle_end/flambda/un_anf.cmo : \ + middle_end/symbol.cmi \ middle_end/semantics_of_primitives.cmi \ middle_end/printclambda.cmi \ utils/misc.cmi \ @@ -5166,6 +5195,7 @@ middle_end/flambda/un_anf.cmo : \ parsing/asttypes.cmi \ middle_end/flambda/un_anf.cmi middle_end/flambda/un_anf.cmx : \ + middle_end/symbol.cmx \ middle_end/semantics_of_primitives.cmx \ middle_end/printclambda.cmx \ utils/misc.cmx \ @@ -5178,6 +5208,7 @@ middle_end/flambda/un_anf.cmx : \ parsing/asttypes.cmi \ middle_end/flambda/un_anf.cmi middle_end/flambda/un_anf.cmi : \ + middle_end/symbol.cmi \ middle_end/clambda.cmi middle_end/flambda/unbox_closures.cmo : \ middle_end/variable.cmi \ @@ -5695,6 +5726,7 @@ driver/optcompile.cmo : \ utils/config.cmi \ middle_end/compilenv.cmi \ driver/compile_common.cmi \ + middle_end/closure/closure_middle_end.cmi \ utils/clflags.cmi \ asmcomp/asmgen.cmi \ driver/optcompile.cmi @@ -5709,6 +5741,7 @@ driver/optcompile.cmx : \ utils/config.cmx \ middle_end/compilenv.cmx \ driver/compile_common.cmx \ + middle_end/closure/closure_middle_end.cmx \ utils/clflags.cmx \ asmcomp/asmgen.cmx \ driver/optcompile.cmi @@ -5912,6 +5945,7 @@ toplevel/opttoploop.cmo : \ driver/compmisc.cmi \ middle_end/compilenv.cmi \ driver/compenv.cmi \ + middle_end/closure/closure_middle_end.cmi \ utils/clflags.cmi \ typing/btype.cmi \ middle_end/backend_intf.cmi \ @@ -5958,6 +5992,7 @@ toplevel/opttoploop.cmx : \ driver/compmisc.cmx \ middle_end/compilenv.cmx \ driver/compenv.cmx \ + middle_end/closure/closure_middle_end.cmx \ utils/clflags.cmx \ typing/btype.cmx \ middle_end/backend_intf.cmi \ diff --git a/Changes b/Changes index 1737f2635..f370fad33 100644 --- a/Changes +++ b/Changes @@ -146,7 +146,7 @@ OCaml 4.09.0 (Mark Shinwell, review by Vincent Laviron) - #2281: Move some middle-end files around - (Mark Shinwell) + (Mark Shinwell, review by Pierre Chambart and Vincent Laviron) - #2283: Add [is_prefix] and [find_and_chop_longest_common_prefix] to [Misc.Stdlib.List] @@ -159,6 +159,10 @@ OCaml 4.09.0 - #2286: Functorise [Consistbl] (Mark Shinwell, review by Gabriel Radanne) +- #2288: Move middle end code from [Asmgen] to [Clambda_middle_end] and + [Flambda_middle_end]. Run [Un_anf] from the middle end, not [Cmmgen]. + (Mark Shinwell, review by Pierre Chambart) + - #2291: Add [Compute_ranges] pass (Mark Shinwell, review by Vincent Laviron) diff --git a/Makefile b/Makefile index 029c88477..c0ec794c2 100644 --- a/Makefile +++ b/Makefile @@ -189,7 +189,8 @@ ASMCOMP=\ # the native code compiler is not present for some particular target. MIDDLE_END_CLOSURE=\ - middle_end/closure/closure.cmo + middle_end/closure/closure.cmo \ + middle_end/closure/closure_middle_end.cmo # Owing to dependencies through [Compilenv], which would be # difficult to remove, some of the lower parts of Flambda (anything that is diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 46f7b2704..6e0df8f73 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -39,41 +39,6 @@ let pass_dump_linear_if ppf flag message phrase = if !flag then fprintf ppf "*** %s@.%a@." message Printlinear.fundecl phrase; phrase -let flambda_raw_clambda_dump_if ppf - ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _; - structured_constants; exported = _; } as input) = - if !dump_rawclambda then - begin - Format.fprintf ppf "@.clambda (before Un_anf):@."; - Printclambda.clambda ppf ulambda; - Symbol.Map.iter (fun sym cst -> - Format.fprintf ppf "%a:@ %a@." - Symbol.print sym - Printclambda.structured_constant cst) - structured_constants - end; - if !dump_cmm then Format.fprintf ppf "@.cmm:@."; - input - -type clambda_and_constants = - Clambda.ulambda * - Clambda.preallocated_block list * - Clambda.preallocated_constant list - -let raw_clambda_dump_if ppf - ((ulambda, _, structured_constants):clambda_and_constants) = - if !dump_rawclambda || !dump_clambda then - begin - Format.fprintf ppf "@.clambda:@."; - Printclambda.clambda ppf ulambda; - List.iter (fun {Clambda.symbol; definition} -> - Format.fprintf ppf "%s:@ %a@." - symbol - Printclambda.structured_constant definition) - structured_constants - end; - if !dump_cmm then Format.fprintf ppf "@.cmm:@." - let rec regalloc ~ppf_dump round fd = if round > 50 then fatal_error(fd.Mach.fun_name ^ @@ -102,7 +67,6 @@ let (++) x f = f x let compile_fundecl ~ppf_dump fd_cmm = Proc.init (); - Cmmgen.reset (); Reg.reset(); fd_cmm ++ Profile.record ~accumulate:true "selection" Selection.fundecl @@ -145,8 +109,7 @@ let compile_genfuns ~ppf_dump f = | _ -> ()) (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) -let compile_unit _output_prefix asm_filename keep_asm - obj_filename gen = +let compile_unit asm_filename keep_asm obj_filename gen = let create_asm = keep_asm || not !Emitaux.binary_backend_available in Emitaux.create_asm_file := create_asm; Misc.try_finally @@ -167,109 +130,49 @@ let compile_unit _output_prefix asm_filename keep_asm if create_asm && not keep_asm then remove_file asm_filename ) -let set_export_info (ulambda, prealloc, structured_constants, export) = - Compilenv.set_export_info export; - (ulambda, prealloc, structured_constants) - let end_gen_implementation ?toplevel ~ppf_dump - (clambda:clambda_and_constants) = + (clambda : Clambda.with_constants) = Emit.begin_assembly (); clambda - ++ Profile.record "cmm" (Cmmgen.compunit ~ppf_dump) + ++ Profile.record "cmm" Cmmgen.compunit ++ Profile.record "compile_phrases" (List.iter (compile_phrase ~ppf_dump)) ++ (fun () -> ()); (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, when part of a C library, won't be discarded by the linker. This is important if a module that uses such a symbol is later dynlinked. *) - compile_phrase ~ppf_dump (Cmmgen.reference_symbols - (List.filter (fun s -> s <> "" && s.[0] <> '%') - (List.map Primitive.native_name !Translmod.primitive_declarations)) - ); + (List.filter_map (fun prim -> + if not (Primitive.native_name_is_external prim) then None + else Some (Primitive.native_name prim)) + !Translmod.primitive_declarations)); Emit.end_assembly () -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_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 ~ppf_dump expr ~what:"init_code", preallocated_blocks, - structured_constants, exported) - ++ set_export_info) - in - let constants = - List.map (fun (symbol, definition) -> - { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol); - exported = true; - definition; - provenance = None; - }) - (Symbol.Map.bindings constants) - in - end_gen_implementation ?toplevel ~ppf_dump - (clambda, preallocated, constants) +type middle_end = + backend:(module Backend_intf.S) + -> filename:string + -> prefixname:string + -> ppf_dump:Format.formatter + -> Lambda.program + -> Clambda.with_constants -let lambda_gen_implementation ?toplevel ~backend ~ppf_dump - (lambda:Lambda.program) = - let clambda = - Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code - in - let provenance : Clambda.usymbol_provenance = - { original_idents = []; - module_path = - Path.Pident (Ident.create_persistent (Compilenv.current_unit_name ())); - } - in - let preallocated_block = - Clambda.{ - symbol = Compilenv.make_symbol None; - exported = true; - tag = 0; - fields = List.init lambda.main_module_block_size (fun _ -> None); - provenance = Some provenance; - } - in - let clambda_and_constants = - clambda, [preallocated_block], Compilenv.structured_constants () - in - Compilenv.clear_structured_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_dump gen_implementation program = +let compile_implementation ?toplevel ~backend ~filename ~prefixname ~middle_end + ~ppf_dump (program : Lambda.program) = let asmfile = if !keep_asm_file || !Emitaux.binary_backend_available then prefixname ^ ext_asm else Filename.temp_file "camlasm" ext_asm in - compile_unit prefixname asmfile !keep_asm_file - (prefixname ^ ext_obj) (fun () -> - Ident.Set.iter Compilenv.require_global required_globals; - gen_implementation ?toplevel ~ppf_dump program) - -let compile_implementation_clambda ?toplevel prefixname - ~backend ~ppf_dump (program:Lambda.program) = - compile_implementation_gen ?toplevel prefixname - ~required_globals:program.Lambda.required_globals - ~ppf_dump (lambda_gen_implementation ~backend) program - -let compile_implementation_flambda ?toplevel prefixname - ~required_globals ~backend ~ppf_dump (program:Flambda.program) = - compile_implementation_gen ?toplevel prefixname - ~required_globals ~ppf_dump (flambda_gen_implementation ~backend) program + compile_unit asmfile !keep_asm_file (prefixname ^ ext_obj) + (fun () -> + Ident.Set.iter Compilenv.require_global program.required_globals; + let clambda_with_constants = + middle_end ~backend ~filename ~prefixname ~ppf_dump program + in + end_gen_implementation ?toplevel ~ppf_dump clambda_with_constants) (* Error report *) diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 160456215..afbdefd67 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -13,20 +13,27 @@ (* *) (**************************************************************************) -(* From lambda to assembly code *) +(** From Lambda to assembly code *) -val compile_implementation_flambda : - ?toplevel:(string -> bool) -> - string -> - required_globals:Ident.Set.t -> - backend:(module Backend_intf.S) -> - ppf_dump:Format.formatter -> Flambda.program -> unit +(** The type of converters from Lambda to Clambda. *) +type middle_end = + backend:(module Backend_intf.S) + -> filename:string + -> prefixname:string + -> ppf_dump:Format.formatter + -> Lambda.program + -> Clambda.with_constants -val compile_implementation_clambda : - ?toplevel:(string -> bool) -> - string -> - backend:(module Backend_intf.S) -> - ppf_dump:Format.formatter -> Lambda.program -> unit +(** Compile an implementation from Lambda using the given middle end. *) +val compile_implementation + : ?toplevel:(string -> bool) + -> backend:(module Backend_intf.S) + -> filename:string + -> prefixname:string + -> middle_end:middle_end + -> ppf_dump:Format.formatter + -> Lambda.program + -> unit val compile_phrase : ppf_dump:Format.formatter -> Cmm.phrase -> unit @@ -37,6 +44,5 @@ val report_error: Format.formatter -> error -> unit val compile_unit: - string(*prefixname*) -> string(*asm file*) -> bool(*keep asm*) -> string(*obj file*) -> (unit -> unit) -> unit diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 1336f6744..b13053c29 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -287,7 +287,7 @@ let link_shared ~ppf_dump objfiles output_name = then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in let startup_obj = output_name ^ ".startup" ^ ext_obj in - Asmgen.compile_unit output_name + Asmgen.compile_unit startup !Clflags.keep_startup_file startup_obj (fun () -> make_shared_startup_file ~ppf_dump @@ -352,7 +352,7 @@ let link ~ppf_dump objfiles output_name = then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in let startup_obj = Filename.temp_file "camlstartup" ext_obj in - Asmgen.compile_unit output_name + Asmgen.compile_unit startup !Clflags.keep_startup_file startup_obj (fun () -> make_startup_file ~ppf_dump units_tolink ~crc_interfaces); Misc.try_finally diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 1bed76f7b..182eb9749 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -99,27 +99,42 @@ let make_package_object ~ppf_dump members targetobj targetname coercion members in let module_ident = Ident.create_persistent targetname in let prefixname = Filename.remove_extension objtemp in - if Config.flambda then begin - let size, lam = Translmod.transl_package_flambda components coercion in - let flam = - Flambda_middle_end.middle_end ~ppf_dump - ~prefixname - ~backend - ~size - ~filename:targetname - ~module_ident - ~module_initializer:lam - in - Asmgen.compile_implementation_flambda - 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 ~backend ~ppf_dump { Lambda.code; main_module_block_size; - module_ident; required_globals = Ident.Set.empty } - end; + let required_globals = Ident.Set.empty in + let program, middle_end = + if Config.flambda then + let main_module_block_size, code = + Translmod.transl_package_flambda components coercion + in + let program = + { Lambda. + code; + main_module_block_size; + module_ident; + required_globals; + } + in + program, Flambda_middle_end.lambda_to_clambda + else + let main_module_block_size, code = + Translmod.transl_store_package components + (Ident.create_persistent targetname) coercion + in + let program = + { Lambda. + code; + main_module_block_size; + module_ident; + required_globals; + } + in + program, Closure_middle_end.lambda_to_clambda + in + Asmgen.compile_implementation ~backend + ~filename:targetname + ~prefixname + ~middle_end + ~ppf_dump + program; let objfiles = List.map (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj) @@ -130,6 +145,7 @@ let make_package_object ~ppf_dump members targetobj targetname coercion remove_file objtemp; if not ok then raise(Error Linking_error) ) + (* Make the .cmx file for the package *) let get_export_info ui = diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index b33b1ec41..712cbaaf9 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -3225,13 +3225,8 @@ and transl_letrec env bindings cont = (* Translate a function definition *) -let transl_function ~ppf_dump f = - let body = - if Config.flambda then - Un_anf.apply ~ppf_dump f.body ~what:f.label - else - f.body - in +let transl_function f = + let body = f.body in let cmm_body = let env = create_env ~environment_param:f.env in if !Clflags.afl_instrument then @@ -3252,17 +3247,17 @@ let transl_function ~ppf_dump f = (* Translate all function definitions *) -let rec transl_all_functions ~ppf_dump already_translated cont = +let rec transl_all_functions already_translated cont = match Cmmgen_state.next_function () with | None -> cont, already_translated | Some f -> let sym = f.label in if String.Set.mem sym already_translated then - transl_all_functions ~ppf_dump already_translated cont + transl_all_functions already_translated cont else begin - transl_all_functions ~ppf_dump + transl_all_functions (String.Set.add sym already_translated) - ((f.dbg, transl_function ~ppf_dump f) :: cont) + ((f.dbg, transl_function f) :: cont) end (* Emit constant closures *) @@ -3349,16 +3344,16 @@ let emit_cmm_data_items_for_constants cont = c := (Cdata cmm) :: !c | Const_table (global, elems) -> c := (Cdata (emit_constant_table (symbol, global) elems)) :: !c) - (Cmmgen_state.constants ()); - Cdata (Cmmgen_state.data_items ()) :: !c + (Cmmgen_state.get_and_clear_constants ()); + Cdata (Cmmgen_state.get_and_clear_data_items ()) :: !c -let transl_all_functions ~ppf_dump cont = +let transl_all_functions cont = let rec aux already_translated cont translated_functions = if Cmmgen_state.no_more_functions () then cont, translated_functions else let translated_functions, already_translated = - transl_all_functions ~ppf_dump already_translated translated_functions + transl_all_functions already_translated translated_functions in aux already_translated cont translated_functions in @@ -3422,7 +3417,8 @@ let emit_preallocated_blocks preallocated_blocks cont = (* Translate a compilation unit *) -let compunit ~ppf_dump (ulam, preallocated_blocks, constants) = +let compunit (ulam, preallocated_blocks, constants) = + assert (Cmmgen_state.no_more_functions ()); let dbg = Debuginfo.none in let init_code = if !Clflags.afl_instrument then @@ -3444,7 +3440,7 @@ let compunit ~ppf_dump (ulam, preallocated_blocks, constants) = else [ Reduce_code_size ]; fun_dbg = Debuginfo.none }] in let c2 = transl_clambda_constants constants c1 in - let c3 = transl_all_functions ~ppf_dump c2 in + let c3 = transl_all_functions c2 in let c4 = emit_preallocated_blocks preallocated_blocks c3 in emit_cmm_data_items_for_constants c4 @@ -3943,6 +3939,3 @@ let plugin_header units = } in global_data "caml_plugin_header" { dynu_magic = Config.cmxs_magic_number; dynu_units = List.map mk units } - -let reset () = - Cmmgen_state.reset () diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index b7388a3f5..8fbcb8524 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -15,9 +15,8 @@ (* Translation from closed lambda to C-- *) -val compunit: - ppf_dump:Format.formatter - -> Clambda.ulambda +val compunit + : Clambda.ulambda * Clambda.preallocated_block list * Clambda.preallocated_constant list -> Cmm.phrase list @@ -38,5 +37,3 @@ val code_segment_table: string list -> Cmm.phrase val predef_exception: int -> string -> Cmm.phrase val plugin_header: (Cmx_format.unit_infos * Digest.t) list -> Cmm.phrase val black_block_header: (*tag:*)int -> (*size:*)int -> nativeint - -val reset : unit -> unit diff --git a/asmcomp/cmmgen_state.ml b/asmcomp/cmmgen_state.ml index b40375a69..8fa856348 100644 --- a/asmcomp/cmmgen_state.ml +++ b/asmcomp/cmmgen_state.ml @@ -39,11 +39,6 @@ let empty = { let state = empty -let reset () = - state.constants <- S.Map.empty; - state.data_items <- []; - Queue.clear state.functions - let add_constant sym cst = state.constants <- S.Map.add sym cst state.constants @@ -53,9 +48,15 @@ let add_data_items items = let add_function func = Queue.add func state.functions -let constants () = state.constants +let get_and_clear_constants () = + let constants = state.constants in + state.constants <- S.Map.empty; + constants -let data_items () = List.concat (List.rev state.data_items) +let get_and_clear_data_items () = + let data_items = List.concat (List.rev state.data_items) in + state.data_items <- []; + data_items let next_function () = match Queue.take state.functions with diff --git a/asmcomp/cmmgen_state.mli b/asmcomp/cmmgen_state.mli index aa9de814b..bfb6121d7 100644 --- a/asmcomp/cmmgen_state.mli +++ b/asmcomp/cmmgen_state.mli @@ -19,8 +19,6 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] -val reset : unit -> unit - type is_global = Global | Local type constant = @@ -33,9 +31,9 @@ val add_data_items : Cmm.data_item list -> unit val add_function : Clambda.ufunction -> unit -val constants : unit -> constant Misc.Stdlib.String.Map.t +val get_and_clear_constants : unit -> constant Misc.Stdlib.String.Map.t -val data_items : unit -> Cmm.data_item list +val get_and_clear_data_items : unit -> Cmm.data_item list val next_function : unit -> Clambda.ufunction option diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 0af391cc5..9ca93c33b 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -48,17 +48,22 @@ let flambda i backend typed = |>> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda |>> Simplif.simplify_lambda |>> print_if i.ppf_dump Clflags.dump_lambda Printlambda.lambda - |> (fun ((module_ident, size), lam) -> - Flambda_middle_end.middle_end - ~ppf_dump:i.ppf_dump - ~prefixname:i.output_prefix - ~size - ~filename:i.source_file - ~module_ident + |> (fun ((module_ident, main_module_block_size), code) -> + let program : Lambda.program = + { Lambda. + module_ident; + main_module_block_size; + required_globals; + code; + } + in + Asmgen.compile_implementation ~backend - ~module_initializer:lam) - |> Asmgen.compile_implementation_flambda - i.output_prefix ~required_globals ~backend ~ppf_dump:i.ppf_dump; + ~filename:i.source_file + ~prefixname:i.output_prefix + ~middle_end:Flambda_middle_end.lambda_to_clambda + ~ppf_dump:i.ppf_dump + program); Compilenv.save_unit_info (cmx i)) let clambda i backend typed = @@ -72,8 +77,12 @@ let clambda i backend typed = let code = Simplif.simplify_lambda program.Lambda.code in { program with Lambda.code } |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program - |> Asmgen.compile_implementation_clambda - i.output_prefix ~backend ~ppf_dump:i.ppf_dump; + |> Asmgen.compile_implementation + ~backend + ~filename:i.source_file + ~prefixname:i.output_prefix + ~middle_end:Closure_middle_end.lambda_to_clambda + ~ppf_dump:i.ppf_dump; Compilenv.save_unit_info (cmx i)) let implementation ~backend ~source_file ~output_prefix = diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml index 406bfbccd..59402629f 100644 --- a/middle_end/clambda.ml +++ b/middle_end/clambda.ml @@ -136,6 +136,9 @@ type preallocated_constant = { provenance : usymbol_provenance option; } +type with_constants = + ulambda * preallocated_block list * preallocated_constant list + (* Comparison functions for constants. We must not use Stdlib.compare because it compares "0.0" and "-0.0" equal. (PR#6442) *) diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli index ddd0956de..9d74eb665 100644 --- a/middle_end/clambda.mli +++ b/middle_end/clambda.mli @@ -151,3 +151,6 @@ type preallocated_constant = { definition : ustructured_constant; provenance : usymbol_provenance option; } + +type with_constants = + ulambda * preallocated_block list * preallocated_constant list diff --git a/middle_end/closure/closure_middle_end.ml b/middle_end/closure/closure_middle_end.ml new file mode 100644 index 000000000..cb593eb0e --- /dev/null +++ b/middle_end/closure/closure_middle_end.ml @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "+a-4-30-40-41-42"] + +let raw_clambda_dump_if ppf + ((ulambda, _, structured_constants) : Clambda.with_constants) = + if !Clflags.dump_rawclambda || !Clflags.dump_clambda then + begin + Format.fprintf ppf "@.clambda:@."; + Printclambda.clambda ppf ulambda; + List.iter (fun { Clambda. symbol; definition; _ } -> + Format.fprintf ppf "%s:@ %a@." + symbol + Printclambda.structured_constant definition) + structured_constants + end; + if !Clflags.dump_cmm then Format.fprintf ppf "@.cmm:@." + +let lambda_to_clambda ~backend ~filename:_ ~prefixname:_ ~ppf_dump + (lambda : Lambda.program) = + let clambda = + Closure.intro ~backend ~size:lambda.main_module_block_size lambda.code + in + let provenance : Clambda.usymbol_provenance = + { original_idents = []; + module_path = + Path.Pident (Ident.create_persistent (Compilenv.current_unit_name ())); + } + in + let preallocated_block = + Clambda.{ + symbol = Compilenv.make_symbol None; + exported = true; + tag = 0; + fields = List.init lambda.main_module_block_size (fun _ -> None); + provenance = Some provenance; + } + in + let constants = Compilenv.structured_constants () in + Compilenv.clear_structured_constants (); + let clambda_and_constants = + clambda, [preallocated_block], constants + in + raw_clambda_dump_if ppf_dump clambda_and_constants; + clambda_and_constants diff --git a/middle_end/closure/closure_middle_end.mli b/middle_end/closure/closure_middle_end.mli new file mode 100644 index 000000000..e0ebb1dec --- /dev/null +++ b/middle_end/closure/closure_middle_end.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val lambda_to_clambda + : backend:(module Backend_intf.S) + -> filename:string + -> prefixname:string + -> ppf_dump:Format.formatter + -> Lambda.program + -> Clambda.with_constants diff --git a/middle_end/flambda/flambda_middle_end.ml b/middle_end/flambda/flambda_middle_end.ml index e604a3285..6330ff12d 100644 --- a/middle_end/flambda/flambda_middle_end.ml +++ b/middle_end/flambda/flambda_middle_end.ml @@ -6,7 +6,7 @@ (* Mark Shinwell and Leo White, Jane Street Europe *) (* *) (* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) +(* Copyright 2014--2019 Jane Street Group LLC *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) @@ -14,7 +14,7 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +[@@@ocaml.warning "+a-4-30-40-41-42-66"] open! Int_replace_polymorphic_compare let _dump_function_sizes flam ~backend = @@ -31,11 +31,8 @@ let _dump_function_sizes flam ~backend = | None -> assert false) set_of_closures.function_decls.funs) -let middle_end ~ppf_dump ~prefixname ~backend - ~size - ~filename - ~module_ident - ~module_initializer = +let lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size ~filename + ~module_ident ~module_initializer = Profile.record_call "flambda" (fun () -> let previous_warning_reporter = !Location.warning_reporter in let module WarningSet = @@ -198,3 +195,54 @@ let middle_end ~ppf_dump ~prefixname ~backend (* dump_function_sizes flam ~backend; *) flam)) ) + +let flambda_raw_clambda_dump_if ppf + ({ Flambda_to_clambda. expr = ulambda; preallocated_blocks = _; + structured_constants; exported = _; } as input) = + if !Clflags.dump_rawclambda then + begin + Format.fprintf ppf "@.clambda (before Un_anf):@."; + Printclambda.clambda ppf ulambda; + Symbol.Map.iter (fun sym cst -> + Format.fprintf ppf "%a:@ %a@." + Symbol.print sym + Printclambda.structured_constant cst) + structured_constants + end; + if !Clflags.dump_cmm then Format.fprintf ppf "@.cmm:@."; + input + +let lambda_to_clambda ~backend ~filename ~prefixname ~ppf_dump + (program : Lambda.program) = + let program = + lambda_to_flambda ~ppf_dump ~prefixname ~backend + ~size:program.main_module_block_size + ~filename + ~module_ident:program.module_ident + ~module_initializer:program.code + in + let export = Build_export_info.build_transient ~backend program in + let clambda, preallocated_blocks, constants = + Profile.record_call "backend" (fun () -> + (program, export) + |> Flambda_to_clambda.convert ~ppf_dump + |> flambda_raw_clambda_dump_if ppf_dump + |> (fun { Flambda_to_clambda. expr; preallocated_blocks; + structured_constants; exported; } -> + Compilenv.set_export_info exported; + let clambda = + Un_anf.apply ~what:(Compilenv.current_unit_symbol ()) + ~ppf_dump expr + in + clambda, preallocated_blocks, structured_constants)) + in + let constants = + List.map (fun (symbol, definition) -> + { Clambda.symbol = Linkage_name.to_string (Symbol.label symbol); + exported = true; + definition; + provenance = None; + }) + (Symbol.Map.bindings constants) + in + clambda, preallocated_blocks, constants diff --git a/middle_end/flambda/flambda_middle_end.mli b/middle_end/flambda/flambda_middle_end.mli index 584cb45a9..e7bb7478b 100644 --- a/middle_end/flambda/flambda_middle_end.mli +++ b/middle_end/flambda/flambda_middle_end.mli @@ -16,14 +16,12 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42"] -(* Translate Lambda code to Flambda code and then optimize it. *) +(** Translate Lambda code to Flambda code, optimize it, and produce Clambda. *) -val middle_end - : ppf_dump:Format.formatter - -> prefixname:string - -> backend:(module Backend_intf.S) - -> size:int +val lambda_to_clambda + : backend:(module Backend_intf.S) -> filename:string - -> module_ident:Ident.t - -> module_initializer:Lambda.lambda - -> Flambda.program + -> prefixname:string + -> ppf_dump:Format.formatter + -> Lambda.program + -> Clambda.with_constants diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 2f60f9fcf..9d6ea1518 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -31,6 +31,9 @@ type t = { Set_of_closures_id.t for_one_or_more_units; imported_units : Simple_value_approx.function_declarations for_one_or_more_units; + ppf_dump : Format.formatter; + mutable constants_for_instrumentation : + Clambda.ustructured_constant Symbol.Map.t; } let get_fun_offset t closure_id = @@ -70,7 +73,7 @@ let is_function_constant t closure_id = (* Instrumentation of closure and field accesses to try to catch compiler bugs. *) -let check_closure ulam named : Clambda.ulambda = +let check_closure t ulam named : Clambda.ulambda = if not !Clflags.clambda_checks then ulam else let desc = @@ -78,14 +81,19 @@ let check_closure ulam named : Clambda.ulambda = ~arity:2 ~alloc:false in let str = Format.asprintf "%a" Flambda.print_named named in - let str_const = - Compilenv.new_structured_constant (Uconst_string str) ~shared:true + let sym = Compilenv.new_const_symbol () in + let sym' = + Symbol.of_global_linkage (Compilation_unit.get_current_exn ()) + (Linkage_name.create sym) in + t.constants_for_instrumentation <- + Symbol.Map.add sym' (Clambda.Uconst_string str) + t.constants_for_instrumentation; Uprim (Pccall desc, - [ulam; Clambda.Uconst (Uconst_ref (str_const, None))], + [ulam; Clambda.Uconst (Uconst_ref (sym, None))], Debuginfo.none) -let check_field ulam pos named_opt : Clambda.ulambda = +let check_field t ulam pos named_opt : Clambda.ulambda = if not !Clflags.clambda_checks then ulam else let desc = @@ -97,11 +105,16 @@ let check_field ulam pos named_opt : Clambda.ulambda = | None -> "" | Some named -> Format.asprintf "%a" Flambda.print_named named in - let str_const = - Compilenv.new_structured_constant (Uconst_string str) ~shared:true + let sym = Compilenv.new_const_symbol () in + let sym' = + Symbol.of_global_linkage (Compilation_unit.get_current_exn ()) + (Linkage_name.create sym) in + t.constants_for_instrumentation <- + Symbol.Map.add sym' (Clambda.Uconst_string str) + t.constants_for_instrumentation; Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos); - Clambda.Uconst (Uconst_ref (str_const, None))], + Clambda.Uconst (Uconst_ref (sym, None))], Debuginfo.none) module Env : sig @@ -258,7 +271,7 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = to_clambda_direct_apply t func args direct_func dbg env | Apply { func; args; kind = Indirect; dbg = dbg } -> let callee = subst_var env func in - Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)), + Ugeneric_apply (check_closure t callee (Flambda.Expr (Var func)), subst_vars env args, dbg) | Switch (arg, sw) -> let aux () : Clambda.ulambda = @@ -368,15 +381,15 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = a [Uoffset] construction in the event that the offset is zero, otherwise we might break pattern matches in Cmmgen (in particular for the compilation of "let rec"). *) - check_closure ( + check_closure t ( build_uoffset - (check_closure (subst_var env set_of_closures) + (check_closure t (subst_var env set_of_closures) (Flambda.Expr (Var set_of_closures))) (get_fun_offset t closure_id)) named | Move_within_set_of_closures { closure; start_from; move_to } -> - check_closure (build_uoffset - (check_closure (subst_var env closure) + check_closure t (build_uoffset + (check_closure t (subst_var env closure) (Flambda.Expr (Var closure))) ((get_fun_offset t move_to) - (get_fun_offset t start_from))) named @@ -386,13 +399,14 @@ and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = let var_offset = get_fv_offset t var in let pos = var_offset - fun_offset in Uprim (Pfield pos, - [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)], + [check_field t (check_closure t ulam (Expr (Var closure))) + pos (Some named)], Debuginfo.none) | Prim (Pfield index, [block], dbg) -> - Uprim (Pfield index, [check_field (subst_var env block) index None], dbg) + Uprim (Pfield index, [check_field t (subst_var env block) index None], dbg) | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) -> Uprim (Psetfield (index, maybe_ptr, init), [ - check_field (subst_var env block) index None; + check_field t (subst_var env block) index None; subst_var env new_value; ], dbg) | Prim (Popaque, args, dbg) -> @@ -569,11 +583,15 @@ and to_clambda_closed_set_of_closures t env symbol env, id :: params) function_decl.params (env, []) in + let body = + Un_anf.apply ~ppf_dump:t.ppf_dump ~what:symbol + (to_clambda t env_body function_decl.body) + in { label = Compilenv.function_label (Closure_id.wrap id); arity = Flambda_utils.function_arity function_decl; params = List.map (fun var -> VP.create var, Lambda.Pgenval) params; return = Lambda.Pgenval; - body = to_clambda t env_body function_decl.body; + body; dbg = function_decl.dbg; env = None; } @@ -698,7 +716,7 @@ type result = { exported : Export_info.t; } -let convert (program, exported_transient) : result = +let convert ~ppf_dump (program, exported_transient) : result = let current_unit = let closures = Closure_id.Map.keys (Flambda_utils.make_closure_map program) @@ -733,10 +751,20 @@ let convert (program, exported_transient) : result = closures; } in - let t = { current_unit; imported_units; } in + let t = + { current_unit; + imported_units; + constants_for_instrumentation = Symbol.Map.empty; + ppf_dump; + } + in let expr, structured_constants, preallocated_blocks = to_clambda_program t Env.empty Symbol.Map.empty program in + let structured_constants = + Symbol.Map.disjoint_union structured_constants + t.constants_for_instrumentation + in let exported = Export_info.t_of_transient exported_transient ~program diff --git a/middle_end/flambda/flambda_to_clambda.mli b/middle_end/flambda/flambda_to_clambda.mli index 8c493d40d..d08af3e2b 100644 --- a/middle_end/flambda/flambda_to_clambda.mli +++ b/middle_end/flambda/flambda_to_clambda.mli @@ -35,4 +35,7 @@ type result = { For direct calls, the hidden closure parameter is added. Switch tables are also built. *) -val convert : Flambda.program * Export_info.transient -> result +val convert + : ppf_dump:Format.formatter + -> Flambda.program * Export_info.transient + -> result diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml index 50f9e7b1e..19b04d85a 100644 --- a/middle_end/flambda/un_anf.ml +++ b/middle_end/flambda/un_anf.ml @@ -799,7 +799,7 @@ and un_anf_list var_info env clams : Clambda.ulambda list = and un_anf_array var_info env clams : Clambda.ulambda array = Array.map (un_anf var_info env) clams -let apply ~ppf_dump clam ~what = +let apply ~what ~ppf_dump clam = let var_info = make_var_info clam in let let_bound_vars_that_can_be_moved = let_bound_vars_that_can_be_moved var_info clam @@ -812,6 +812,8 @@ let apply ~ppf_dump clam ~what = let clam = un_anf var_info V.Map.empty clam in if !Clflags.dump_clambda then begin Format.fprintf ppf_dump - "@.un-anf (%s):@ %a@." what Printclambda.clambda clam + "@.un-anf (%a):@ %a@." + Symbol.print what + Printclambda.clambda clam end; clam diff --git a/middle_end/flambda/un_anf.mli b/middle_end/flambda/un_anf.mli index 92ea06cd0..a7d5e94e8 100644 --- a/middle_end/flambda/un_anf.mli +++ b/middle_end/flambda/un_anf.mli @@ -17,7 +17,7 @@ (** Expand ANF-like constructs so that pattern matches in [Cmmgen] will work correctly. *) val apply - : ppf_dump:Format.formatter + : what:Symbol.t + -> ppf_dump:Format.formatter -> Clambda.ulambda - -> what:string -> Clambda.ulambda diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index 0d1f73921..83a1a46fa 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -248,19 +248,24 @@ let load_lambda ppf ~module_ident ~required_globals lam size = if !Clflags.keep_asm_file then !phrase_name ^ ext_dll else Filename.temp_file ("caml" ^ !phrase_name) ext_dll in - let fn = Filename.chop_extension dll in - if not Config.flambda then - Asmgen.compile_implementation_clambda - ~toplevel:need_symbol fn ~backend ~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_dump:ppf - (Flambda_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); + let filename = Filename.chop_extension dll in + let program = + { Lambda. + code = slam; + main_module_block_size = size; + module_ident; + required_globals; + } + in + let middle_end = + if Config.flambda then Flambda_middle_end.lambda_to_clambda + else Closure_middle_end.lambda_to_clambda + in + Asmgen.compile_implementation ~toplevel:need_symbol + ~backend ~filename ~prefixname:"" + ~middle_end ~ppf_dump:ppf program; + Asmlink.call_linker_shared [filename ^ ext_obj] dll; + Sys.remove (filename ^ ext_obj); let dll = if Filename.is_implicit dll diff --git a/typing/primitive.ml b/typing/primitive.ml index c28bdfbf4..0d88f2908 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -200,6 +200,9 @@ let native_name p = let byte_name p = p.prim_name +let native_name_is_external p = + p.prim_native_name <> "" && p.prim_native_name.[0] <> '%' + let report_error ppf err = match err with | Old_style_float_with_native_repr_attribute -> diff --git a/typing/primitive.mli b/typing/primitive.mli index 02ece7d96..ddd397796 100644 --- a/typing/primitive.mli +++ b/typing/primitive.mli @@ -63,6 +63,11 @@ val print val native_name: description -> string val byte_name: description -> string +(** [native_name_is_externa] returns [true] iff the [native_name] for the + given primitive identifies that the primitive is not implemented in the + compiler itself. *) +val native_name_is_external : description -> bool + type error = | Old_style_float_with_native_repr_attribute | Old_style_noalloc_with_noalloc_attribute