asmcomp/asmlink.ml

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