(**************************************************************************) (* *) (* 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. *) (* *) (**************************************************************************) (* Link a set of .cmx/.o files and produce an executable *) open Misc open Config open Cmx_format open Compilenv module String = Misc.Stdlib.String type error = | File_not_found of filepath | Not_an_object_file of filepath | Inconsistent_interface of modname * filepath * filepath | Inconsistent_implementation of modname * filepath * filepath | Assembler_error of filepath | Linking_error of int | Missing_cmx of filepath * modname | Link_error of Linkdeps.error exception Error of error (* Consistency check between interfaces and implementations *) module Cmi_consistbl = Consistbl.Make (Misc.Stdlib.String) let crc_interfaces = Cmi_consistbl.create () let interfaces = ref ([] : string list) module Cmx_consistbl = Consistbl.Make (Misc.Stdlib.String) let crc_implementations = Cmx_consistbl.create () let implementations = ref ([] : string list) let cmx_required = ref ([] : string list) let check_consistency file_name unit crc = begin try List.iter (fun (name, crco) -> interfaces := name :: !interfaces; match crco with None -> () | Some crc -> Cmi_consistbl.check crc_interfaces name crc file_name) unit.ui_imports_cmi with Cmi_consistbl.Inconsistency { unit_name = name; inconsistent_source = user; original_source = auth; } -> raise(Error(Inconsistent_interface(name, user, auth))) end; begin try List.iter (fun (name, crco) -> implementations := name :: !implementations; match crco with None -> if List.mem name !cmx_required then raise(Error(Missing_cmx(file_name, name))) | Some crc -> Cmx_consistbl.check crc_implementations name crc file_name) unit.ui_imports_cmx with Cmx_consistbl.Inconsistency { unit_name = name; inconsistent_source = user; original_source = auth; } -> raise(Error(Inconsistent_implementation(name, user, auth))) end; implementations := unit.ui_name :: !implementations; Cmx_consistbl.check crc_implementations unit.ui_name crc file_name; if unit.ui_symbol <> unit.ui_name then cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = Cmi_consistbl.extract !interfaces crc_interfaces let extract_crc_implementations () = Cmx_consistbl.extract !implementations crc_implementations (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) let lib_ccobjs = ref [] let lib_ccopts = ref [] let add_ccobjs origin l = if not !Clflags.no_auto_link then begin lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; let replace_origin = Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin in lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts end let runtime_lib () = let libname = "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in try if !Clflags.nopervasives || not !Clflags.with_runtime then [] else [ Load_path.find libname ] with Not_found -> raise(Error(File_not_found libname)) (* First pass: determine which units are needed *) 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 Load_path.find obj_name with Not_found -> raise(Error(File_not_found obj_name)) in if Filename.check_suffix file_name ".cmx" then begin (* This is a .cmx file. It must be linked in any case. Read the infos to see which modules it requires. *) let (info, crc) = read_unit_info file_name in Unit (file_name,info,crc) end else if Filename.check_suffix file_name ".cmxa" then begin let infos = try read_library_info file_name with Compilenv.Error(Not_a_unit_info _) -> raise(Error(Not_an_object_file file_name)) in Library (file_name,infos) end else raise(Error(Not_an_object_file file_name)) let scan_file ldeps file tolink = match file with | Unit (file_name,info,crc) -> (* This is a .cmx file. It must be linked in any case. *) Linkdeps.add ldeps ~filename:file_name ~compunit:info.ui_name ~provides:[info.ui_name] ~requires:(List.map fst info.ui_imports_cmx); (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; List.fold_right (fun (info, crc) reqd -> if info.ui_force_link || !Clflags.link_everything || Linkdeps.required ldeps info.ui_name then begin Linkdeps.add ldeps ~filename:file_name ~compunit:info.ui_name ~provides:[info.ui_name] ~requires:(List.map fst 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 *) let force_linking_of_startup ~ppf_dump = Asmgen.compile_phrase ~ppf_dump (Cmm.Cdata ([Cmm.Csymbol_address "caml_startup"])) let make_globals_map units_list ~crc_interfaces = let crc_interfaces = String.Tbl.of_seq (List.to_seq crc_interfaces) in let defined = List.map (fun (unit, _, impl_crc) -> let intf_crc = String.Tbl.find crc_interfaces unit.ui_name in String.Tbl.remove crc_interfaces unit.ui_name; (unit.ui_name, intf_crc, Some impl_crc, unit.ui_defines)) units_list in String.Tbl.fold (fun name intf acc -> (name, intf, None, []) :: acc) crc_interfaces defined let make_startup_file ~ppf_dump units_list ~crc_interfaces = 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 *) Emit.begin_assembly (); let name_list = List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in let entry = Cmm_helpers.entry_point name_list in let entry = if Config.tsan then match entry with | Cfunction ({ fun_body; _ } as cf) -> Cmm.Cfunction { cf with fun_body = Thread_sanitizer.wrap_entry_exit fun_body } | _ -> assert false else entry in compile_phrase entry; let units = List.map (fun (info,_,_) -> info) units_list in List.iter compile_phrase (Cmm_helpers.emit_preallocated_blocks [] (* add gc_roots (for dynlink) *) (Cmm_helpers.generic_functions false units)); Array.iteri (fun i name -> compile_phrase (Cmm_helpers.predef_exception i name)) Runtimedef.builtin_exceptions; compile_phrase (Cmm_helpers.global_table name_list); let globals_map = make_globals_map units_list ~crc_interfaces in compile_phrase (Cmm_helpers.globals_map globals_map); compile_phrase(Cmm_helpers.data_segment_table ("_startup" :: name_list)); if !Clflags.function_sections then compile_phrase (Cmm_helpers.code_segment_table("_hot" :: "_startup" :: name_list)) else compile_phrase(Cmm_helpers.code_segment_table("_startup" :: name_list)); let all_names = "_startup" :: "_system" :: name_list in compile_phrase (Cmm_helpers.frame_table all_names); if !Clflags.output_complete_object then force_linking_of_startup ~ppf_dump; Emit.end_assembly () 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 (); List.iter compile_phrase (Cmm_helpers.emit_preallocated_blocks [] (* add gc_roots (for dynlink) *) (Cmm_helpers.generic_functions true (List.map fst units))); compile_phrase (Cmm_helpers.plugin_header units); compile_phrase (Cmm_helpers.global_table (List.map (fun (ui,_) -> ui.ui_symbol) units)); if !Clflags.output_complete_object then 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 () let call_linker_shared file_list output_name = let exitcode = Ccomp.call_linker Ccomp.Dll output_name file_list "" in if not (exitcode = 0) then raise(Error(Linking_error exitcode)) let link_shared ~ppf_dump objfiles output_name = Profile.record_call output_name (fun () -> let obj_infos = List.map read_file objfiles in let ldeps = Linkdeps.create ~complete:false in let units_tolink = List.fold_right (scan_file ldeps) obj_infos [] in (match Linkdeps.check ldeps with | None -> () | Some e -> raise (Error (Link_error e))); 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 (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 else Filename.temp_file "camlstartup" ext_asm in let startup_obj = output_name ^ ".startup" ^ ext_obj in Asmgen.compile_unit ~output_prefix:output_name ~asm_filename:startup ~keep_asm:!Clflags.keep_startup_file ~obj_filename:startup_obj (fun () -> make_shared_startup_file ~ppf_dump (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) ); call_linker_shared (startup_obj :: objfiles) output_name; remove_file startup_obj ) let call_linker file_list startup_file output_name = let main_dll = !Clflags.output_c_object && Filename.check_suffix output_name Config.ext_dll and main_obj_runtime = !Clflags.output_complete_object in let files = startup_file :: (List.rev file_list) in let files, ldflags = if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then files @ (List.rev !Clflags.ccobjs) @ runtime_lib (), native_ldflags ^ " " ^ (if !Clflags.nopervasives || (main_obj_runtime && not main_dll) then "" else Config.native_c_libraries) else files, "" in let mode = if main_dll then Ccomp.MainDll else if !Clflags.output_c_object then Ccomp.Partial else Ccomp.Exe in let exitcode = Ccomp.call_linker mode output_name files ldflags in if not (exitcode = 0) then raise(Error(Linking_error exitcode)) (* Main entry point *) let link ~ppf_dump objfiles output_name = Profile.record_call output_name (fun () -> let stdlib = "stdlib.cmxa" in let stdexit = "std_exit.cmx" in let objfiles = if !Clflags.nopervasives then objfiles else if !Clflags.output_c_object then stdlib :: objfiles else stdlib :: (objfiles @ [stdexit]) in let obj_infos = List.map read_file objfiles in let ldeps = Linkdeps.create ~complete:true in let units_tolink = List.fold_right (scan_file ldeps) obj_infos [] in (match Linkdeps.check ldeps with | None -> () | Some e -> raise (Error (Link_error e))); List.iter (fun (info, file_name, crc) -> check_consistency file_name info crc) units_tolink; let crc_interfaces = extract_crc_interfaces () in Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; (* put user's opts first *) let startup = if !Clflags.keep_startup_file || !Emitaux.binary_backend_available 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_prefix:output_name ~asm_filename:startup ~keep_asm:!Clflags.keep_startup_file ~obj_filename:startup_obj (fun () -> make_startup_file ~ppf_dump units_tolink ~crc_interfaces); Misc.try_finally (fun () -> call_linker (List.filter_map object_file_name_of_file obj_infos) startup_obj output_name) ~always:(fun () -> remove_file startup_obj) ) (* Error report *) module Style = Misc.Style open Format_doc let report_error_doc ppf = function | File_not_found name -> fprintf ppf "Cannot find file %a" Style.inline_code name | Not_an_object_file name -> fprintf ppf "The file %a is not a compilation unit description" Location.Doc.quoted_filename name | Inconsistent_interface(intf, file1, file2) -> fprintf ppf "@[Files %a@ and %a@ make inconsistent assumptions \ over interface %a@]" Location.Doc.quoted_filename file1 Location.Doc.quoted_filename file2 Style.inline_code intf | Inconsistent_implementation(intf, file1, file2) -> fprintf ppf "@[Files %a@ and %a@ make inconsistent assumptions \ over implementation %a@]" Location.Doc.quoted_filename file1 Location.Doc.quoted_filename file2 Style.inline_code intf | Assembler_error file -> fprintf ppf "Error while assembling %a" Location.Doc.quoted_filename file | Linking_error exitcode -> fprintf ppf "Error during linking (exit code %d)" exitcode | Missing_cmx(filename, name) -> fprintf ppf "@[File %a@ was compiled without access@ \ to the %a file@ for module %a,@ \ which was produced by %a.@ \ Please recompile %a@ with the correct %a option@ \ so that %a@ is found.@]" Location.Doc.quoted_filename filename Style.inline_code ".cmx" Style.inline_code name Style.inline_code "ocamlopt -for-pack" Location.Doc.quoted_filename filename Style.inline_code "-I" Style.inline_code (name^".cmx") | Link_error e -> Linkdeps.report_error_doc ~print_filename:Location.Doc.filename ppf e let () = Location.register_error_of_exn (function | Error err -> Some (Location.error_of_printer_file report_error_doc err) | _ -> None ) let report_error = Format_doc.compat report_error_doc let reset () = Cmi_consistbl.clear crc_interfaces; Cmx_consistbl.clear crc_implementations; cmx_required := []; interfaces := []; implementations := []; lib_ccobjs := []; lib_ccopts := []