flambda-backend: Simplify processing and remove dead code (error paths) in asmlink (port upstream PR#9943) (oxcaml#557)

gretay-js · dbuenzli · web-flow · commit f0b6d68e861d · 2022-03-18T16:15:50.000Z
* Asmlink.object_file_name removal: add object_file_name_of_file

An analysis of the code should convince yourself that the
[object_file_name] function is not needed and that its erroring paths
are dead code.

The reasoning is the following: all the uses of [object_file_name] in
asmlink.ml are performed on [obj_name]s which went through [read_file]
before. The latter does exactly the same file name lookup and erroring
treatement, except not in a stringly manner like [object_file_name]
does.

This new function derives the same information as [object_file_name]
except it does it on the [file] datatype returned by [read_file].
Note that all the erroring code paths of [object_file_name] have been
handled by the [read_file] which derived the [file] value.

We integrate the logic added by PR #9011 for empty cmxa here.

* Asmlink.object_file_name removal: remove.

This commit does the following four things (it's difficult
to them in separate commits that compile).

1) It removes the [read_file] from [scan_file]. Reading the files is
   done seperately before returning an [obj_infos] list of [file]
   values. This turns [scan_file] into a function that operates on
   values of type [file].

2) In [scan_file] it removes the separate list of [obj_files]
   introduced by #9011. We can derive the same list using the function
   [object_file_name_of_file] introduced in the previous commit on the
   list of [obj_infos]. Effectively we bring back [scan_file] to the
   state before #9011 modulo the [read_file] removal.

3) We derive the list of [obj_files] directly from the
   [obj_infos] list via [object_file_name_of_file]. Note that
   the logic introduced by #9011 is preserved by virtue of
   [object_file_name_of_file]'s optional result.

4) Deletes [object_file_name] which is no longer used.

Co-authored-by: Daniel Bünzli &lt;daniel.buenzli@erratique.ch&gt;
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
@@ -124,19 +124,6 @@ let runtime_lib () =
   with Not_found ->
     raise(Error(File_not_found libname))
 
-let object_file_name name =
-  let file_name =
-    try
-      Load_path.find name
-    with Not_found ->
-      fatal_errorf "Asmlink.object_file_name: %s not found" name in
-  if Filename.check_suffix file_name ".cmx" then
-    Filename.chop_suffix file_name ".cmx" ^ ext_obj
-  else if Filename.check_suffix file_name ".cmxa" then
-    Filename.chop_suffix file_name ".cmxa" ^ ext_lib
-  else
-    fatal_error "Asmlink.object_file_name: bad ext"
-
 (* First pass: determine which units are needed *)
 
 let missing_globals = (Hashtbl.create 17 : (string, string list ref) Hashtbl.t)
@@ -164,6 +151,17 @@ type file =
   | Unit of string * unit_infos * Digest.t
   | Library of string * library_infos
 
+let object_file_name_of_file = function
+  | Unit (fname, _, _) -> Some (Filename.chop_suffix fname ".cmx" ^ ext_obj)
+  | Library (fname, infos) ->
+      let obj_file = Filename.chop_suffix fname ".cmxa" ^ ext_lib in
+      (* MSVC doesn't support empty .lib files, and macOS struggles to make
+         them (#6550), so there shouldn't be one if the .cmxa contains no
+         units. The file_exists check is added to be ultra-defensive for the
+         case where a user has manually added things to the .a/.lib file *)
+      if infos.lib_units = [] && not (Sys.file_exists obj_file) then None else
+      Some obj_file
+
 let read_file obj_name =
   let file_name =
     try
@@ -186,42 +184,30 @@ let read_file obj_name =
   end
   else raise(Error(Not_an_object_file file_name))
 
-let scan_file obj_name (tolink, objfiles) = match read_file obj_name with
+let scan_file file tolink = match file with
   | Unit (file_name,info,crc) ->
       (* This is a .cmx file. It must be linked in any case. *)
       remove_required info.ui_name;
       List.iter (add_required file_name) info.ui_imports_cmx;
-      ((info, file_name, crc) :: tolink, obj_name :: objfiles)
+      (info, file_name, crc) :: tolink
   | Library (file_name,infos) ->
       (* This is an archive file. Each unit contained in it will be linked
          in only if needed. *)
       add_ccobjs (Filename.dirname file_name) infos;
-      let tolink =
-        List.fold_right
-          (fun (info, crc) reqd ->
-             if info.ui_force_link
-               || !Clflags.link_everything
-               || is_required info.ui_name
-             then begin
-               remove_required info.ui_name;
-               List.iter (add_required (Printf.sprintf "%s(%s)"
-                                          file_name info.ui_name))
-                 info.ui_imports_cmx;
-               (info, file_name, crc) :: reqd
-             end else
-               reqd)
-          infos.lib_units tolink
-      and objfiles =
-        if infos.lib_units = []
-        && not (Sys.file_exists (object_file_name obj_name)) then
-          (* MSVC doesn't support empty .lib files, and macOS struggles to make
-             them (#6550), so there shouldn't be one if the .cmxa contains no
-             units. The file_exists check is added to be ultra-defensive for the
-             case where a user has manually added things to the .a/.lib file *)
-          objfiles
-        else
-          obj_name :: objfiles
-      in (tolink, objfiles)
+      List.fold_right
+        (fun (info, crc) reqd ->
+           if info.ui_force_link
+           || !Clflags.link_everything
+           || is_required info.ui_name
+           then begin
+             remove_required info.ui_name;
+             List.iter (add_required (Printf.sprintf "%s(%s)"
+                                        file_name info.ui_name))
+               info.ui_imports_cmx;
+             (info, file_name, crc) :: reqd
+           end else
+           reqd)
+        infos.lib_units tolink
 
 (* Second pass: generate the startup file and link it with everything else *)
 
@@ -295,17 +281,16 @@ let call_linker_shared file_list output_name =
 
 let link_shared ~ppf_dump objfiles output_name =
   Profile.record_call output_name (fun () ->
-    let units_tolink, objfiles =
-      List.fold_right scan_file objfiles ([], [])
-    in
+    let obj_infos = List.map read_file objfiles in
+    let units_tolink = List.fold_right scan_file obj_infos [] in
     List.iter
       (fun (info, file_name, crc) -> check_consistency file_name info crc)
       units_tolink;
     Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
     Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts;
-    let objfiles = List.rev_map object_file_name objfiles @
+    let objfiles =
+      List.rev (List.filter_map object_file_name_of_file obj_infos) @
       (List.rev !Clflags.ccobjs) in
-
     let startup =
       if !Clflags.keep_startup_file || !Emitaux.binary_backend_available
       then output_name ^ ".startup" ^ ext_asm
@@ -355,9 +340,8 @@ let link ~ppf_dump objfiles output_name =
       if !Clflags.nopervasives then objfiles
       else if !Clflags.output_c_object then stdlib :: objfiles
       else stdlib :: (objfiles @ [stdexit]) in
-    let units_tolink, objfiles =
-      List.fold_right scan_file objfiles ([], [])
-    in
+    let obj_infos = List.map read_file objfiles in
+    let units_tolink = List.fold_right scan_file obj_infos [] in
     Array.iter remove_required Runtimedef.builtin_exceptions;
     begin match extract_missing_globals() with
       [] -> ()
@@ -381,7 +365,7 @@ let link ~ppf_dump objfiles output_name =
       (fun () -> make_startup_file ~ppf_dump units_tolink ~crc_interfaces);
     Misc.try_finally
       (fun () ->
-         call_linker (List.map object_file_name objfiles)
+         call_linker (List.filter_map object_file_name_of_file obj_infos)
            startup_obj output_name)
       ~always:(fun () -> remove_file startup_obj)
   )
