diff --git a/backend/asmgen.ml b/backend/asmgen.ml index b3ce9f56641..78d132e4262 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -166,11 +166,12 @@ let should_use_linscan fun_codegen_options = let if_emit_do f x = if should_emit () then f x else () let emit_begin_assembly unix = if_emit_do Emit.begin_assembly unix -let emit_end_assembly filename () = +let emit_end_assembly ~sourcefile () = if_emit_do (fun () -> try Emit.end_assembly () with Emitaux.Error e -> - raise (Error (Asm_generation(filename, e)))) + let sourcefile = Option.value ~default:"*none*" sourcefile in + raise (Error (Asm_generation(sourcefile, e)))) () let emit_data dl = if_emit_do Emit.data dl @@ -517,7 +518,7 @@ let compile_unit ~output_prefix ~asm_filename ~keep_asm ~obj_filename ~may_reduc ) let end_gen_implementation unix ?toplevel ~ppf_dump ~sourcefile make_cmm = - Emitaux.Dwarf_helpers.init ~disable_dwarf:false sourcefile; + Emitaux.Dwarf_helpers.init ~disable_dwarf:false ~sourcefile; emit_begin_assembly unix; make_cmm () ++ (fun x -> if Clflags.should_stop_after Compiler_pass.Middle_end then exit 0 else x) @@ -536,12 +537,11 @@ let end_gen_implementation unix ?toplevel ~ppf_dump ~sourcefile make_cmm = if not (Primitive.native_name_is_external prim) then None else Some (Cmm.global_symbol (Primitive.native_name prim))) !Translmod.primitive_declarations)); - emit_end_assembly sourcefile () + emit_end_assembly ~sourcefile () type direct_to_cmm = ppf_dump:Format.formatter -> prefixname:string - -> filename:string -> Lambda.program -> Cmm.phrase list @@ -554,7 +554,7 @@ let asm_filename output_prefix = else Filename.temp_file "camlasm" ext_asm let compile_implementation unix ?toplevel ~pipeline - ~filename ~prefixname ~ppf_dump (program : Lambda.program) = + ~sourcefile ~prefixname ~ppf_dump (program : Lambda.program) = compile_unit ~ppf_dump ~output_prefix:prefixname ~asm_filename:(asm_filename prefixname) ~keep_asm:!keep_asm_file ~obj_filename:(prefixname ^ ext_obj) @@ -565,10 +565,8 @@ let compile_implementation unix ?toplevel ~pipeline Compilenv.record_external_symbols (); match pipeline with | Direct_to_cmm direct_to_cmm -> - let cmm_phrases = - direct_to_cmm ~ppf_dump ~prefixname ~filename program - in - end_gen_implementation unix ?toplevel ~ppf_dump ~sourcefile:filename + let cmm_phrases = direct_to_cmm ~ppf_dump ~prefixname program in + end_gen_implementation unix ?toplevel ~ppf_dump ~sourcefile (fun () -> cmm_phrases)) let linear_gen_implementation unix filename = @@ -585,10 +583,12 @@ let linear_gen_implementation unix filename = | Func f -> emit_fundecl f in start_from_emit := true; - Emitaux.Dwarf_helpers.init ~disable_dwarf:false filename; + (* CR mshinwell: set [sourcefile] properly; [filename] isn't a .ml file *) + let sourcefile = Some filename in + Emitaux.Dwarf_helpers.init ~disable_dwarf:false ~sourcefile; emit_begin_assembly unix; Profile.record "Emit" (List.iter emit_item) linear_unit_info.items; - emit_end_assembly filename () + emit_end_assembly ~sourcefile () let compile_implementation_linear unix output_prefix ~progname = compile_unit ~may_reduce_heap:true ~output_prefix diff --git a/backend/asmgen.mli b/backend/asmgen.mli index 6b64dcc7c74..4e0bf743a55 100644 --- a/backend/asmgen.mli +++ b/backend/asmgen.mli @@ -20,7 +20,6 @@ type direct_to_cmm = ppf_dump:Format.formatter -> prefixname:string - -> filename:string -> Lambda.program -> Cmm.phrase list @@ -33,7 +32,7 @@ val compile_implementation : (module Compiler_owee.Unix_intf.S) -> ?toplevel:(string -> bool) -> pipeline:pipeline - -> filename:string + -> sourcefile:string option -> prefixname:string -> ppf_dump:Format.formatter -> Lambda.program diff --git a/backend/asmpackager.ml b/backend/asmpackager.ml index 7edf5329edf..4efea8994c4 100644 --- a/backend/asmpackager.ml +++ b/backend/asmpackager.ml @@ -29,7 +29,6 @@ type error = | Assembler_error of string | File_not_found of string - exception Error of error (* Read the unit information from a .cmx file. *) @@ -42,11 +41,10 @@ type pack_member = pm_kind: pack_member_kind } let read_member_info pack_path file = ( - let name = - String.capitalize_ascii(Filename.basename(chop_extensions file)) - |> CU.Name.of_string in + let unit_info = Unit_info.Artifact.from_filename file in + let name = Unit_info.Artifact.modname unit_info |> CU.Name.of_string in let kind = - if Filename.check_suffix file ".cmi" then + if Unit_info.is_cmi unit_info then PM_intf else begin let (info, crc) = Compilenv.read_unit_info file in @@ -86,17 +84,18 @@ let check_units members = type flambda2 = ppf_dump:Format.formatter -> prefixname:string -> - filename:string -> keep_symbol_tables:bool -> Lambda.program -> Cmm.phrase list -let make_package_object unix ~ppf_dump members targetobj targetname coercion +let make_package_object unix ~ppf_dump members target coercion ~(flambda2 : flambda2) = - Profile.record_call (Printf.sprintf "pack(%s)" targetname) (fun () -> + let pack_name = + Printf.sprintf "pack(%s)" (Unit_info.Artifact.modname target) in + Profile.record_call pack_name (fun () -> let objtemp = if !Clflags.keep_asm_file - then Filename.remove_extension targetobj ^ ".pack" ^ Config.ext_obj + then Unit_info.Artifact.prefix target ^ ".pack" ^ Config.ext_obj else (* Put the full name of the module in the temporary file name to avoid collisions with MSVC's link /lib in case of successive @@ -115,7 +114,7 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion | PM_impl _ -> Some(CU.create_child (CU.get_current_exn ()) m.pm_name)) members in let for_pack_prefix = CU.Prefix.from_clflags () in - let modname = CU.Name.of_string targetname in + let modname = CU.Name.of_string (Unit_info.Artifact.modname target) in let compilation_unit = CU.create for_pack_prefix modname in let prefixname = Filename.remove_extension objtemp in let required_globals = Compilation_unit.Set.empty in @@ -140,7 +139,7 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion Direct_to_cmm (flambda2 ~keep_symbol_tables:true) in Asmgen.compile_implementation ~pipeline unix - ~filename:targetname + ~sourcefile:(Unit_info.Artifact.source_file target) ~prefixname ~ppf_dump program; @@ -149,7 +148,8 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion (fun m -> Filename.remove_extension m.pm_file ^ Config.ext_obj) (List.filter (fun m -> m.pm_kind <> PM_intf) members) in let exitcode = - Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) "" + Ccomp.call_linker Ccomp.Partial (Unit_info.Artifact.filename target) + (objtemp :: objfiles) "" in remove_file objtemp; if not (exitcode = 0) then raise(Error Linking_error) @@ -212,17 +212,16 @@ let build_package_cmx members cmxfile = (* Make the .cmx and the .o for the package *) -let package_object_files unix ~ppf_dump files targetcmx - targetobj targetname coercion ~flambda2 = +let package_object_files unix ~ppf_dump files target + targetcmx coercion ~flambda2 = let pack_path = let for_pack_prefix = CU.Prefix.from_clflags () in - let name = targetname |> CU.Name.of_string in + let name = Unit_info.Artifact.modname target |> CU.Name.of_string in CU.create for_pack_prefix name in let members = map_left_right (read_member_info pack_path) files in check_units members; - make_package_object unix ~ppf_dump members targetobj targetname coercion - ~flambda2; + make_package_object unix ~ppf_dump members target coercion ~flambda2; build_package_cmx members targetcmx (* The entry point *) @@ -234,45 +233,52 @@ let package_files unix ~ppf_dump initial_env files targetcmx ~flambda2 = try Load_path.find f with Not_found -> raise(Error(File_not_found f))) files in - let prefix = chop_extensions targetcmx in - let targetcmi = prefix ^ ".cmi" in - let targetobj = Filename.remove_extension targetcmx ^ Config.ext_obj in - let targetname = String.capitalize_ascii(Filename.basename prefix) in + let cmx = Unit_info.Artifact.from_filename targetcmx in + let cmi = Unit_info.companion_cmi cmx in + let obj = Unit_info.companion_obj cmx in (* Set the name of the current "input" *) Location.input_name := targetcmx; (* Set the name of the current compunit *) let comp_unit = let for_pack_prefix = CU.Prefix.from_clflags () in - CU.create for_pack_prefix (CU.Name.of_string targetname) + CU.create for_pack_prefix + (CU.Name.of_string (Unit_info.Artifact.modname cmi)) in Compilenv.reset comp_unit; Misc.try_finally (fun () -> let coercion = - Typemod.package_units initial_env files targetcmi comp_unit in - package_object_files unix ~ppf_dump files targetcmx targetobj targetname + Typemod.package_units initial_env files cmi comp_unit in + package_object_files unix ~ppf_dump files obj targetcmx coercion ~flambda2 ) - ~exceptionally:(fun () -> remove_file targetcmx; remove_file targetobj) + ~exceptionally:(fun () -> + remove_file targetcmx; remove_file (Unit_info.Artifact.filename obj) + ) (* Error report *) open Format +module Style = Misc.Style let report_error ppf = function Illegal_renaming(name, file, id) -> fprintf ppf "Wrong file naming: %a@ contains the code for\ @ %a when %a was expected" - Location.print_filename file CU.Name.print name CU.Name.print id + (Style.as_inline_code Location.print_filename) file + (Style.as_inline_code CU.Name.print) name + (Style.as_inline_code CU.Name.print) id | Forward_reference(file, ident) -> - fprintf ppf "Forward reference to %a in file %a" CU.Name.print ident - Location.print_filename file + fprintf ppf "Forward reference to %a in file %a" + (Style.as_inline_code CU.Name.print) ident + (Style.as_inline_code Location.print_filename) file | Wrong_for_pack(file, path) -> fprintf ppf "File %a@ was not compiled with the `-for-pack %a' option" - Location.print_filename file Compilation_unit.print path + (Style.as_inline_code Location.print_filename) file + (Style.as_inline_code CU.print) path | File_not_found file -> - fprintf ppf "File %s not found" file + fprintf ppf "File %a not found" Style.inline_code file | Assembler_error file -> - fprintf ppf "Error while assembling %s" file + fprintf ppf "Error while assembling %a" Style.inline_code file | Linking_error -> fprintf ppf "Error during partial linking" diff --git a/backend/asmpackager.mli b/backend/asmpackager.mli index 42aae720f85..ddfe4bb3352 100644 --- a/backend/asmpackager.mli +++ b/backend/asmpackager.mli @@ -25,7 +25,6 @@ val package_files -> flambda2:( ppf_dump:Format.formatter -> prefixname:string -> - filename:string -> keep_symbol_tables:bool -> Lambda.program -> Cmm.phrase list) diff --git a/backend/emitaux.ml b/backend/emitaux.ml index f37ee5bcfed..a571826c39c 100644 --- a/backend/emitaux.ml +++ b/backend/emitaux.ml @@ -483,7 +483,7 @@ module Dwarf_helpers = struct dwarf := None; sourcefile_for_dwarf := None - let init ~disable_dwarf sourcefile = + let init ~disable_dwarf ~sourcefile = reset_dwarf (); let can_emit_dwarf = !Clflags.debug @@ -496,7 +496,7 @@ module Dwarf_helpers = struct Target_system.architecture (), Target_system.derived_system () ) with - | true, (X86_64 | AArch64), _ -> sourcefile_for_dwarf := Some sourcefile + | true, (X86_64 | AArch64), _ -> sourcefile_for_dwarf := sourcefile | true, _, _ | false, _, _ -> () let emit_dwarf () = diff --git a/backend/emitaux.mli b/backend/emitaux.mli index 7f345cc150b..0abe310539b 100644 --- a/backend/emitaux.mli +++ b/backend/emitaux.mli @@ -135,7 +135,7 @@ type error = | Inconsistent_probe_init of string * Debuginfo.t module Dwarf_helpers : sig - val init : disable_dwarf:bool -> string -> unit + val init : disable_dwarf:bool -> sourcefile:string option -> unit val begin_dwarf : build_asm_directives:(unit -> (module Asm_targets.Asm_directives_intf.S)) -> diff --git a/middle_end/flambda2/flambda2.ml b/middle_end/flambda2/flambda2.ml index e4f0a06e52f..0ef2a970413 100644 --- a/middle_end/flambda2/flambda2.ml +++ b/middle_end/flambda2/flambda2.ml @@ -82,7 +82,7 @@ let print_flexpect name main_dump_ppf ~raw_flambda:old_unit new_unit = ~header:("Before and after " ^ name) ~f:pp_flambda_as_flexpect (old_unit, new_unit) -let lambda_to_cmm ~ppf_dump:ppf ~prefixname ~filename:_ ~keep_symbol_tables +let lambda_to_cmm ~ppf_dump:ppf ~prefixname ~keep_symbol_tables (program : Lambda.program) = let compilation_unit = program.compilation_unit in let module_block_size_in_words = program.main_module_block_size in diff --git a/middle_end/flambda2/flambda2.mli b/middle_end/flambda2/flambda2.mli index 12db584fc8e..f6ece2be583 100644 --- a/middle_end/flambda2/flambda2.mli +++ b/middle_end/flambda2/flambda2.mli @@ -20,7 +20,6 @@ val lambda_to_cmm : ppf_dump:Format.formatter -> prefixname:string -> - filename:string -> keep_symbol_tables:bool -> Lambda.program -> Cmm.phrase list