Fix Asmpackager for 5.2 (#2791)

Fix Asmpackager + related files

(cherry picked from commit b16c28b)

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

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

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"
 

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)

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 () =

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)) ->

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

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