1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6(* *) 7(* Copyright 1996 Institut National de Recherche en Informatique et *) 8(* en Automatique. *) 9(* *) 10(* All rights reserved. This file is distributed under the terms of *) 11(* the GNU Lesser General Public License version 2.1, with the *) 12(* special exception on linking described in the file LICENSE. *) 13(* *) 14(**************************************************************************) 15 16(* Link a set of .cmx/.o files and produce an executable *) 17 18open Misc 19open Config 20open Cmx_format 21open Compilenv 22 23type error = 24 File_not_found of string 25 | Not_an_object_file of string 26 | Missing_implementations of (string * string list) list 27 | Inconsistent_interface of string * string * string 28 | Inconsistent_implementation of string * string * string 29 | Assembler_error of string 30 | Linking_error 31 | Multiple_definition of string * string * string 32 | Missing_cmx of string * string 33 34exception Error of error 35 36(* Consistency check between interfaces and implementations *) 37 38let crc_interfaces = Consistbl.create () 39let interfaces = ref ([] : string list) 40let crc_implementations = Consistbl.create () 41let implementations = ref ([] : string list) 42let implementations_defined = ref ([] : (string * string) list) 43let cmx_required = ref ([] : string list) 44 45let check_consistency file_name unit crc = 46 begin try 47 List.iter 48 (fun (name, crco) -> 49 interfaces := name :: !interfaces; 50 match crco with 51 None -> () 52 | Some crc -> 53 if name = unit.ui_name 54 then Consistbl.set crc_interfaces name crc file_name 55 else Consistbl.check crc_interfaces name crc file_name) 56 unit.ui_imports_cmi 57 with Consistbl.Inconsistency(name, user, auth) -> 58 raise(Error(Inconsistent_interface(name, user, auth))) 59 end; 60 begin try 61 List.iter 62 (fun (name, crco) -> 63 implementations := name :: !implementations; 64 match crco with 65 None -> 66 if List.mem name !cmx_required then 67 raise(Error(Missing_cmx(file_name, name))) 68 | Some crc -> 69 Consistbl.check crc_implementations name crc file_name) 70 unit.ui_imports_cmx 71 with Consistbl.Inconsistency(name, user, auth) -> 72 raise(Error(Inconsistent_implementation(name, user, auth))) 73 end; 74 begin try 75 let source = List.assoc unit.ui_name !implementations_defined in 76 raise (Error(Multiple_definition(unit.ui_name, file_name, source))) 77 with Not_found -> () 78 end; 79 implementations := unit.ui_name :: !implementations; 80 Consistbl.set crc_implementations unit.ui_name crc file_name; 81 implementations_defined := 82 (unit.ui_name, file_name) :: !implementations_defined; 83 if unit.ui_symbol <> unit.ui_name then 84 cmx_required := unit.ui_name :: !cmx_required 85 86let extract_crc_interfaces () = 87 Consistbl.extract !interfaces crc_interfaces 88let extract_crc_implementations () = 89 Consistbl.extract !implementations crc_implementations 90 91(* Add C objects and options and "custom" info from a library descriptor. 92 See bytecomp/bytelink.ml for comments on the order of C objects. *) 93 94let lib_ccobjs = ref [] 95let lib_ccopts = ref [] 96 97let add_ccobjs origin l = 98 if not !Clflags.no_auto_link then begin 99 lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; 100 let replace_origin = 101 Misc.replace_substring ~before:"$CAMLORIGIN" ~after:origin 102 in 103 lib_ccopts := List.map replace_origin l.lib_ccopts @ !lib_ccopts 104 end 105 106let runtime_lib () = 107 let libname = 108 if !Clflags.gprofile 109 then "libasmrunp" ^ ext_lib 110 else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in 111 try 112 if !Clflags.nopervasives then [] 113 else [ find_in_path !load_path libname ] 114 with Not_found -> 115 raise(Error(File_not_found libname)) 116 117let object_file_name name = 118 let file_name = 119 try 120 find_in_path !load_path name 121 with Not_found -> 122 fatal_error "Asmlink.object_file_name: not found" in 123 if Filename.check_suffix file_name ".cmx" then 124 Filename.chop_suffix file_name ".cmx" ^ ext_obj 125 else if Filename.check_suffix file_name ".cmxa" then 126 Filename.chop_suffix file_name ".cmxa" ^ ext_lib 127 else 128 fatal_error "Asmlink.object_file_name: bad ext" 129 130(* First pass: determine which units are needed *) 131 132let missing_globals = (Hashtbl.create 17 : (string, string list ref) Hashtbl.t) 133 134let is_required name = 135 try ignore (Hashtbl.find missing_globals name); true 136 with Not_found -> false 137 138let add_required by (name, _crc) = 139 try 140 let rq = Hashtbl.find missing_globals name in 141 rq := by :: !rq 142 with Not_found -> 143 Hashtbl.add missing_globals name (ref [by]) 144 145let remove_required name = 146 Hashtbl.remove missing_globals name 147 148let extract_missing_globals () = 149 let mg = ref [] in 150 Hashtbl.iter (fun md rq -> mg := (md, !rq) :: !mg) missing_globals; 151 !mg 152 153type file = 154 | Unit of string * unit_infos * Digest.t 155 | Library of string * library_infos 156 157let read_file obj_name = 158 let file_name = 159 try 160 find_in_path !load_path obj_name 161 with Not_found -> 162 raise(Error(File_not_found obj_name)) in 163 if Filename.check_suffix file_name ".cmx" then begin 164 (* This is a .cmx file. It must be linked in any case. 165 Read the infos to see which modules it requires. *) 166 let (info, crc) = read_unit_info file_name in 167 Unit (file_name,info,crc) 168 end 169 else if Filename.check_suffix file_name ".cmxa" then begin 170 let infos = 171 try read_library_info file_name 172 with Compilenv.Error(Not_a_unit_info _) -> 173 raise(Error(Not_an_object_file file_name)) 174 in 175 Library (file_name,infos) 176 end 177 else raise(Error(Not_an_object_file file_name)) 178 179let scan_file obj_name tolink = match read_file obj_name with 180 | Unit (file_name,info,crc) -> 181 (* This is a .cmx file. It must be linked in any case. *) 182 remove_required info.ui_name; 183 List.iter (add_required file_name) info.ui_imports_cmx; 184 (info, file_name, crc) :: tolink 185 | Library (file_name,infos) -> 186 (* This is an archive file. Each unit contained in it will be linked 187 in only if needed. *) 188 add_ccobjs (Filename.dirname file_name) infos; 189 List.fold_right 190 (fun (info, crc) reqd -> 191 if info.ui_force_link 192 || !Clflags.link_everything 193 || is_required info.ui_name 194 then begin 195 remove_required info.ui_name; 196 List.iter (add_required (Printf.sprintf "%s(%s)" 197 file_name info.ui_name)) 198 info.ui_imports_cmx; 199 (info, file_name, crc) :: reqd 200 end else 201 reqd) 202 infos.lib_units tolink 203 204(* Second pass: generate the startup file and link it with everything else *) 205 206let make_startup_file ppf units_list = 207 let compile_phrase p = Asmgen.compile_phrase ppf p in 208 Location.input_name := "caml_startup"; (* set name of "current" input *) 209 Compilenv.reset ~source_provenance:Timings.Startup "_startup"; 210 (* set the name of the "current" compunit *) 211 Emit.begin_assembly (); 212 let name_list = 213 List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in 214 compile_phrase (Cmmgen.entry_point name_list); 215 let units = List.map (fun (info,_,_) -> info) units_list in 216 List.iter compile_phrase (Cmmgen.generic_functions false units); 217 Array.iteri 218 (fun i name -> compile_phrase (Cmmgen.predef_exception i name)) 219 Runtimedef.builtin_exceptions; 220 compile_phrase (Cmmgen.global_table name_list); 221 compile_phrase 222 (Cmmgen.globals_map 223 (List.map 224 (fun (unit,_,crc) -> 225 let intf_crc = 226 try 227 match List.assoc unit.ui_name unit.ui_imports_cmi with 228 None -> assert false 229 | Some crc -> crc 230 with Not_found -> assert false 231 in 232 (unit.ui_name, intf_crc, crc, unit.ui_defines)) 233 units_list)); 234 compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); 235 compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); 236 let all_names = "_startup" :: "_system" :: name_list in 237 compile_phrase (Cmmgen.frame_table all_names); 238 if Config.spacetime then begin 239 compile_phrase (Cmmgen.spacetime_shapes all_names); 240 end; 241 Emit.end_assembly () 242 243let make_shared_startup_file ppf units = 244 let compile_phrase p = Asmgen.compile_phrase ppf p in 245 Location.input_name := "caml_startup"; 246 Compilenv.reset ~source_provenance:Timings.Startup "_shared_startup"; 247 Emit.begin_assembly (); 248 List.iter compile_phrase 249 (Cmmgen.generic_functions true (List.map fst units)); 250 compile_phrase (Cmmgen.plugin_header units); 251 compile_phrase 252 (Cmmgen.global_table 253 (List.map (fun (ui,_) -> ui.ui_symbol) units)); 254 (* this is to force a reference to all units, otherwise the linker 255 might drop some of them (in case of libraries) *) 256 Emit.end_assembly () 257 258let call_linker_shared file_list output_name = 259 if not (Ccomp.call_linker Ccomp.Dll output_name file_list "") 260 then raise(Error Linking_error) 261 262let link_shared ppf objfiles output_name = 263 let units_tolink = List.fold_right scan_file objfiles [] in 264 List.iter 265 (fun (info, file_name, crc) -> check_consistency file_name info crc) 266 units_tolink; 267 Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; 268 Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; 269 let objfiles = List.rev (List.map object_file_name objfiles) @ 270 (List.rev !Clflags.ccobjs) in 271 272 let startup = 273 if !Clflags.keep_startup_file || !Emitaux.binary_backend_available 274 then output_name ^ ".startup" ^ ext_asm 275 else Filename.temp_file "camlstartup" ext_asm in 276 let startup_obj = output_name ^ ".startup" ^ ext_obj in 277 Asmgen.compile_unit ~source_provenance:Timings.Startup output_name 278 startup !Clflags.keep_startup_file startup_obj 279 (fun () -> 280 make_shared_startup_file ppf 281 (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) 282 ); 283 call_linker_shared (startup_obj :: objfiles) output_name; 284 remove_file startup_obj 285 286let call_linker file_list startup_file output_name = 287 let main_dll = !Clflags.output_c_object 288 && Filename.check_suffix output_name Config.ext_dll 289 and main_obj_runtime = !Clflags.output_complete_object 290 in 291 let files = startup_file :: (List.rev file_list) in 292 let libunwind = 293 if not Config.spacetime then [] 294 else if not Config.libunwind_available then [] 295 else String.split_on_char ' ' Config.libunwind_link_flags 296 in 297 let files, c_lib = 298 if (not !Clflags.output_c_object) || main_dll || main_obj_runtime then 299 files @ (List.rev !Clflags.ccobjs) @ runtime_lib () @ libunwind, 300 (if !Clflags.nopervasives || main_obj_runtime 301 then "" else Config.native_c_libraries) 302 else 303 files, "" 304 in 305 let mode = 306 if main_dll then Ccomp.MainDll 307 else if !Clflags.output_c_object then Ccomp.Partial 308 else Ccomp.Exe 309 in 310 if not (Ccomp.call_linker mode output_name files c_lib) 311 then raise(Error Linking_error) 312 313(* Main entry point *) 314 315let link ppf objfiles output_name = 316 let stdlib = 317 if !Clflags.gprofile then "stdlib.p.cmxa" else "stdlib.cmxa" in 318 let stdexit = 319 if !Clflags.gprofile then "std_exit.p.cmx" else "std_exit.cmx" in 320 let objfiles = 321 if !Clflags.nopervasives then objfiles 322 else if !Clflags.output_c_object then stdlib :: objfiles 323 else stdlib :: (objfiles @ [stdexit]) in 324 let units_tolink = List.fold_right scan_file objfiles [] in 325 Array.iter remove_required Runtimedef.builtin_exceptions; 326 begin match extract_missing_globals() with 327 [] -> () 328 | mg -> raise(Error(Missing_implementations mg)) 329 end; 330 List.iter 331 (fun (info, file_name, crc) -> check_consistency file_name info crc) 332 units_tolink; 333 Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; 334 Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; 335 (* put user's opts first *) 336 let startup = 337 if !Clflags.keep_startup_file || !Emitaux.binary_backend_available 338 then output_name ^ ".startup" ^ ext_asm 339 else Filename.temp_file "camlstartup" ext_asm in 340 let startup_obj = Filename.temp_file "camlstartup" ext_obj in 341 Asmgen.compile_unit ~source_provenance:Timings.Startup output_name 342 startup !Clflags.keep_startup_file startup_obj 343 (fun () -> make_startup_file ppf units_tolink); 344 Misc.try_finally 345 (fun () -> 346 call_linker (List.map object_file_name objfiles) startup_obj output_name) 347 (fun () -> remove_file startup_obj) 348 349(* Error report *) 350 351open Format 352 353let report_error ppf = function 354 | File_not_found name -> 355 fprintf ppf "Cannot find file %s" name 356 | Not_an_object_file name -> 357 fprintf ppf "The file %a is not a compilation unit description" 358 Location.print_filename name 359 | Missing_implementations l -> 360 let print_references ppf = function 361 | [] -> () 362 | r1 :: rl -> 363 fprintf ppf "%s" r1; 364 List.iter (fun r -> fprintf ppf ",@ %s" r) rl in 365 let print_modules ppf = 366 List.iter 367 (fun (md, rq) -> 368 fprintf ppf "@ @[<hov 2>%s referenced from %a@]" md 369 print_references rq) in 370 fprintf ppf 371 "@[<v 2>No implementations provided for the following modules:%a@]" 372 print_modules l 373 | Inconsistent_interface(intf, file1, file2) -> 374 fprintf ppf 375 "@[<hov>Files %a@ and %a@ make inconsistent assumptions \ 376 over interface %s@]" 377 Location.print_filename file1 378 Location.print_filename file2 379 intf 380 | Inconsistent_implementation(intf, file1, file2) -> 381 fprintf ppf 382 "@[<hov>Files %a@ and %a@ make inconsistent assumptions \ 383 over implementation %s@]" 384 Location.print_filename file1 385 Location.print_filename file2 386 intf 387 | Assembler_error file -> 388 fprintf ppf "Error while assembling %a" Location.print_filename file 389 | Linking_error -> 390 fprintf ppf "Error during linking" 391 | Multiple_definition(modname, file1, file2) -> 392 fprintf ppf 393 "@[<hov>Files %a@ and %a@ both define a module named %s@]" 394 Location.print_filename file1 395 Location.print_filename file2 396 modname 397 | Missing_cmx(filename, name) -> 398 fprintf ppf 399 "@[<hov>File %a@ was compiled without access@ \ 400 to the .cmx file@ for module %s,@ \ 401 which was produced by `ocamlopt -for-pack'.@ \ 402 Please recompile %a@ with the correct `-I' option@ \ 403 so that %s.cmx@ is found.@]" 404 Location.print_filename filename name 405 Location.print_filename filename 406 name 407 408let () = 409 Location.register_error_of_exn 410 (function 411 | Error err -> Some (Location.error_of_printer_file report_error err) 412 | _ -> None 413 ) 414 415let reset () = 416 Consistbl.clear crc_interfaces; 417 Consistbl.clear crc_implementations; 418 implementations_defined := []; 419 cmx_required := []; 420 interfaces := []; 421 implementations := [] 422