bytecomp/bytelink.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 .cmo files and produce a bytecode executable. *)
  16
  17 open Sys
  18 open Misc
  19 open Config
  20 open Instruct
  21 open Cmo_format
  22
  23 type error =
  24     File_not_found of string
  25   | Not_an_object_file of string
  26   | Symbol_error of string * Symtable.error
  27   | Inconsistent_import of string * string * string
  28   | Custom_runtime
  29   | File_exists of string
  30   | Cannot_open_dll of string
  31
  32 exception Error of error
  33
  34 type link_action =
  35     Link_object of string * compilation_unit
  36       (* Name of .cmo file and descriptor of the unit *)
  37   | Link_archive of string * compilation_unit list
  38       (* Name of .cma file and descriptors of the units to be linked. *)
  39
  40 (* Add C objects and options from a library descriptor *)
  41 (* Ignore them if -noautolink or -use-runtime or -use-prim was given *)
  42
  43 let lib_ccobjs = ref []
  44 let lib_ccopts = ref []
  45 let lib_dllibs = ref []
  46
  47 let add_ccobjs l =
  48   if not !Clflags.no_auto_link
  49       && String.length !Clflags.use_runtime = 0
  50       && String.length !Clflags.use_prims = 0
  51   then begin
  52     if l.lib_custom then Clflags.custom_runtime := true;
  53     lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs;
  54     lib_ccopts := l.lib_ccopts @ !lib_ccopts;
  55     lib_dllibs := l.lib_dllibs @ !lib_dllibs
  56   end
  57
  58 (* A note on ccobj ordering:
  59    - Clflags.ccobjs is in reverse order w.r.t. what was given on the
  60         ocamlc command line;
  61    - l.lib_ccobjs is also in reverse order w.r.t. what was given on the
  62         ocamlc -a command line when the library was created;
  63    - Clflags.ccobjs is reversed just before calling the C compiler for the
  64         custom link;
  65    - .cma files on the command line of ocamlc are scanned right to left;
  66    - Before linking, we add lib_ccobjs after Clflags.ccobjs.
  67    Thus, for ocamlc a.cma b.cma obj1 obj2
  68    where a.cma was built with ocamlc -i ... obja1 obja2
  69      and b.cma was built with ocamlc -i ... objb1 objb2
  70    lib_ccobjs starts as [],
  71    becomes objb2 objb1 when b.cma is scanned,
  72    then obja2 obja1 objb2 objb1 when a.cma is scanned.
  73    Clflags.ccobjs was initially obj2 obj1.
  74    and is set to obj2 obj1 obja2 obja1 objb2 objb1.
  75    Finally, the C compiler is given objb1 objb2 obja1 obja2 obj1 obj2,
  76    which is what we need.  (If b depends on a, a.cma must appear before
  77    b.cma, but b's C libraries must appear before a's C libraries.)
  78 *)
  79
  80 (* First pass: determine which units are needed *)
  81
  82 module IdentSet =
  83   Set.Make(struct
  84     type t = Ident.t
  85     let compare = compare
  86   end)
  87
  88 let missing_globals = ref IdentSet.empty
  89
  90 let is_required (rel, pos) =
  91   match rel with
  92     Reloc_setglobal id ->
  93       IdentSet.mem id !missing_globals
  94   | _ -> false
  95
  96 let add_required (rel, pos) =
  97   match rel with
  98     Reloc_getglobal id ->
  99       missing_globals := IdentSet.add id !missing_globals
 100   | _ -> ()
 101
 102 let remove_required (rel, pos) =
 103   match rel with
 104     Reloc_setglobal id ->
 105       missing_globals := IdentSet.remove id !missing_globals
 106   | _ -> ()
 107
 108 let scan_file obj_name tolink =
 109   let file_name =
 110     try
 111       find_in_path !load_path obj_name
 112     with Not_found ->
 113       raise(Error(File_not_found obj_name)) in
 114   let ic = open_in_bin file_name in
 115   try
 116     let buffer = String.create (String.length cmo_magic_number) in
 117     really_input ic buffer 0 (String.length cmo_magic_number);
 118     if buffer = cmo_magic_number then begin
 119       (* This is a .cmo file. It must be linked in any case.
 120          Read the relocation information to see which modules it
 121          requires. *)
 122       let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
 123       seek_in ic compunit_pos;
 124       let compunit = (input_value ic : compilation_unit) in
 125       close_in ic;
 126       List.iter add_required compunit.cu_reloc;
 127       Link_object(file_name, compunit) :: tolink
 128     end
 129     else if buffer = cma_magic_number then begin
 130       (* This is an archive file. Each unit contained in it will be linked
 131          in only if needed. *)
 132       let pos_toc = input_binary_int ic in    (* Go to table of contents *)
 133       seek_in ic pos_toc;
 134       let toc = (input_value ic : library) in
 135       close_in ic;
 136       add_ccobjs toc;
 137       let required =
 138         List.fold_right
 139           (fun compunit reqd ->
 140             if compunit.cu_force_link
 141             || !Clflags.link_everything
 142             || List.exists is_required compunit.cu_reloc
 143             then begin
 144               List.iter remove_required compunit.cu_reloc;
 145               List.iter add_required compunit.cu_reloc;
 146               compunit :: reqd
 147             end else
 148               reqd)
 149           toc.lib_units [] in
 150       Link_archive(file_name, required) :: tolink
 151     end
 152     else raise(Error(Not_an_object_file file_name))
 153   with
 154     End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name))
 155   | x -> close_in ic; raise x
 156
 157 (* Second pass: link in the required units *)
 158
 159 (* Consistency check between interfaces *)
 160
 161 let crc_interfaces = Consistbl.create ()
 162
 163 let check_consistency file_name cu =
 164   try
 165     List.iter
 166       (fun (name, crc) ->
 167         if name = cu.cu_name
 168         then Consistbl.set crc_interfaces name crc file_name
 169         else Consistbl.check crc_interfaces name crc file_name)
 170       cu.cu_imports
 171   with Consistbl.Inconsistency(name, user, auth) ->
 172     raise(Error(Inconsistent_import(name, user, auth)))
 173
 174 let extract_crc_interfaces () =
 175   Consistbl.extract crc_interfaces
 176
 177 (* Record compilation events *)
 178
 179 let debug_info = ref ([] : (int * string) list)
 180
 181 (* Link in a compilation unit *)
 182
 183 let link_compunit output_fun currpos_fun inchan file_name compunit =
 184   check_consistency file_name compunit;
 185   seek_in inchan compunit.cu_pos;
 186   let code_block = String.create compunit.cu_codesize in
 187   really_input inchan code_block 0 compunit.cu_codesize;
 188   Symtable.patch_object code_block compunit.cu_reloc;
 189   if !Clflags.debug && compunit.cu_debug > 0 then begin
 190     seek_in inchan compunit.cu_debug;
 191     let buffer = String.create compunit.cu_debugsize in
 192     really_input inchan buffer 0 compunit.cu_debugsize;
 193     debug_info := (currpos_fun(), buffer) :: !debug_info
 194   end;
 195   output_fun code_block;
 196   if !Clflags.link_everything then
 197     List.iter Symtable.require_primitive compunit.cu_primitives
 198
 199 (* Link in a .cmo file *)
 200
 201 let link_object output_fun currpos_fun file_name compunit =
 202   let inchan = open_in_bin file_name in
 203   try
 204     link_compunit output_fun currpos_fun inchan file_name compunit;
 205     close_in inchan
 206   with
 207     Symtable.Error msg ->
 208       close_in inchan; raise(Error(Symbol_error(file_name, msg)))
 209   | x ->
 210       close_in inchan; raise x
 211
 212 (* Link in a .cma file *)
 213
 214 let link_archive output_fun currpos_fun file_name units_required =
 215   let inchan = open_in_bin file_name in
 216   try
 217     List.iter
 218       (fun cu ->
 219          let name = file_name ^ "(" ^ cu.cu_name ^ ")" in
 220          try
 221            link_compunit output_fun currpos_fun inchan name cu
 222          with Symtable.Error msg ->
 223            raise(Error(Symbol_error(name, msg))))
 224       units_required;
 225     close_in inchan
 226   with x -> close_in inchan; raise x
 227
 228 (* Link in a .cmo or .cma file *)
 229
 230 let link_file output_fun currpos_fun = function
 231     Link_object(file_name, unit) ->
 232       link_object output_fun currpos_fun file_name unit
 233   | Link_archive(file_name, units) ->
 234       link_archive output_fun currpos_fun file_name units
 235
 236 (* Output the debugging information *)
 237 (* Format is:
 238       <int32>          number of event lists
 239       <int32>          offset of first event list
 240       <output_value>   first event list
 241       ...
 242       <int32>          offset of last event list
 243       <output_value>   last event list *)
 244
 245 let output_debug_info oc =
 246   output_binary_int oc (List.length !debug_info);
 247   List.iter
 248     (fun (ofs, evl) -> output_binary_int oc ofs; output_string oc evl)
 249     !debug_info;
 250   debug_info := []
 251
 252 (* Output a list of strings with 0-termination *)
 253
 254 let output_stringlist oc l =
 255   List.iter (fun s -> output_string oc s; output_byte oc 0) l
 256
 257 (* Transform a file name into an absolute file name *)
 258
 259 let make_absolute file =
 260   if Filename.is_relative file
 261   then Filename.concat (Sys.getcwd()) file
 262   else file
 263
 264 (* Create a bytecode executable file *)
 265
 266 let link_bytecode tolink exec_name standalone =
 267   Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *)
 268   let outchan =
 269     open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
 270                  0o777 exec_name in
 271   try
 272     if standalone then begin
 273       (* Copy the header *)
 274       try
 275         let header =
 276           if String.length !Clflags.use_runtime > 0
 277           then "camlheader_ur" else "camlheader" in
 278         let inchan = open_in_bin (find_in_path !load_path header) in
 279         copy_file inchan outchan;
 280         close_in inchan
 281       with Not_found | Sys_error _ -> ()
 282     end;
 283     Bytesections.init_record outchan;
 284     (* The path to the bytecode interpreter (in use_runtime mode) *)
 285     if String.length !Clflags.use_runtime > 0 then begin
 286       output_string outchan (make_absolute !Clflags.use_runtime);
 287       output_char outchan '\n';
 288       Bytesections.record outchan "RNTM"
 289     end;
 290     (* The bytecode *)
 291     let start_code = pos_out outchan in
 292     Symtable.init();
 293     Consistbl.clear crc_interfaces;
 294     let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in
 295     if standalone then begin
 296       (* Initialize the DLL machinery *)
 297       Dll.init_compile !Clflags.no_std_include;
 298       Dll.add_path !load_path;
 299       try Dll.open_dlls Dll.For_checking sharedobjs
 300       with Failure reason -> raise(Error(Cannot_open_dll reason))
 301     end;
 302     let output_fun = output_string outchan
 303     and currpos_fun () = pos_out outchan - start_code in
 304     List.iter (link_file output_fun currpos_fun) tolink;
 305     if standalone then Dll.close_all_dlls();
 306     (* The final STOP instruction *)
 307     output_byte outchan Opcodes.opSTOP;
 308     output_byte outchan 0; output_byte outchan 0; output_byte outchan 0;
 309     Bytesections.record outchan "CODE";
 310     (* DLL stuff *)
 311     if standalone then begin
 312       (* The extra search path for DLLs *)
 313       output_stringlist outchan !Clflags.dllpaths;
 314       Bytesections.record outchan "DLPT";
 315       (* The names of the DLLs *)
 316       output_stringlist outchan sharedobjs;
 317       Bytesections.record outchan "DLLS"
 318     end;
 319     (* The names of all primitives *)
 320     Symtable.output_primitive_names outchan;
 321     Bytesections.record outchan "PRIM";
 322     (* The table of global data *)
 323     output_value outchan (Symtable.initial_global_table());
 324     Bytesections.record outchan "DATA";
 325     (* The map of global identifiers *)
 326     Symtable.output_global_map outchan;
 327     Bytesections.record outchan "SYMB";
 328     (* CRCs for modules *)
 329     output_value outchan (extract_crc_interfaces());
 330     Bytesections.record outchan "CRCS";
 331     (* Debug info *)
 332     if !Clflags.debug then begin
 333       output_debug_info outchan;
 334       Bytesections.record outchan "DBUG"
 335     end;
 336     (* The table of contents and the trailer *)
 337     Bytesections.write_toc_and_trailer outchan;
 338     close_out outchan
 339   with x ->
 340     close_out outchan;
 341     remove_file exec_name;
 342     raise x
 343
 344 (* Output a string as a C array of unsigned ints *)
 345
 346 let output_code_string_counter = ref 0
 347
 348 let output_code_string outchan code =
 349   let pos = ref 0 in
 350   let len = String.length code in
 351   while !pos < len do
 352     let c1 = Char.code(code.[!pos]) in
 353     let c2 = Char.code(code.[!pos + 1]) in
 354     let c3 = Char.code(code.[!pos + 2]) in
 355     let c4 = Char.code(code.[!pos + 3]) in
 356     pos := !pos + 4;
 357     Printf.fprintf outchan "0x%02x%02x%02x%02x, " c4 c3 c2 c1;
 358     incr output_code_string_counter;
 359     if !output_code_string_counter >= 6 then begin
 360       output_char outchan '\n';
 361       output_code_string_counter := 0
 362     end
 363   done
 364
 365 (* Output a string as a C string *)
 366
 367 let output_data_string outchan data =
 368   let counter = ref 0 in
 369   for i = 0 to String.length data - 1 do
 370     Printf.fprintf outchan "%d, " (Char.code(data.[i]));
 371     incr counter;
 372     if !counter >= 12 then begin
 373       output_string outchan "\n";
 374       counter := 0
 375     end
 376   done
 377
 378 (* Output a bytecode executable as a C file *)
 379
 380 let link_bytecode_as_c tolink outfile =
 381   let outchan = open_out outfile in
 382   try
 383     (* The bytecode *)
 384     output_string outchan "#include <caml/mlvalues.h>\n";
 385     output_string outchan "\
 386 CAMLextern void caml_startup_code(
 387            code_t code, asize_t code_size,
 388            char *data, asize_t data_size,
 389            char *section_table, asize_t section_table_size,
 390            char **argv);\n";
 391     output_string outchan "static int caml_code[] = {\n";
 392     Symtable.init();
 393     Consistbl.clear crc_interfaces;
 394     let output_fun = output_code_string outchan
 395     and currpos_fun () = 0 in
 396     List.iter (link_file output_fun currpos_fun) tolink;
 397     (* The final STOP instruction *)
 398     Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP;
 399     (* The table of global data *)
 400     output_string outchan "static char caml_data[] = {\n";
 401     output_data_string outchan
 402       (Marshal.to_string (Symtable.initial_global_table()) []);
 403     output_string outchan "\n};\n\n";
 404     (* The sections *)
 405     let sections =
 406       [ "SYMB", Symtable.data_global_map();
 407         "PRIM", Obj.repr(Symtable.data_primitive_names());
 408         "CRCS", Obj.repr(extract_crc_interfaces()) ] in
 409     output_string outchan "static char caml_sections[] = {\n";
 410     output_data_string outchan
 411       (Marshal.to_string sections []);
 412     output_string outchan "\n};\n\n";
 413     (* The table of primitives *)
 414     Symtable.output_primitive_table outchan;
 415     (* The entry point *)
 416     output_string outchan "\n
 417 void caml_startup(char ** argv)
 418 {
 419   caml_startup_code(caml_code, sizeof(caml_code),
 420                     caml_data, sizeof(caml_data),
 421                     caml_sections, sizeof(caml_sections),
 422                     argv);
 423 }\n";
 424     close_out outchan
 425   with x ->
 426     close_out outchan;
 427     raise x
 428
 429 (* Build a custom runtime *)
 430
 431 let build_custom_runtime prim_name exec_name =
 432   match Config.ccomp_type with
 433     "cc" ->
 434       Ccomp.command
 435        (Printf.sprintf
 436           "%s -o %s %s %s %s %s %s -lcamlrun %s"
 437           !Clflags.c_linker
 438           (Filename.quote exec_name)
 439           (Clflags.std_include_flag "-I")
 440           (String.concat " " (List.rev !Clflags.ccopts))
 441           prim_name
 442           (Ccomp.quote_files
 443             (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir)
 444                       !load_path))
 445           (Ccomp.quote_files (List.rev !Clflags.ccobjs))
 446           Config.bytecomp_c_libraries)
 447   | "msvc" ->
 448       let retcode =
 449       Ccomp.command
 450        (Printf.sprintf
 451           "%s /Fe%s %s %s %s %s %s %s"
 452           !Clflags.c_linker
 453           (Filename.quote exec_name)
 454           (Clflags.std_include_flag "-I")
 455           prim_name
 456           (Ccomp.quote_files
 457             (List.rev_map Ccomp.expand_libname !Clflags.ccobjs))
 458           (Filename.quote (Ccomp.expand_libname "-lcamlrun"))
 459           Config.bytecomp_c_libraries
 460           (Ccomp.make_link_options !Clflags.ccopts)) in
 461       (* C compiler doesn't clean up after itself.  Note that the .obj
 462          file is created in the current working directory. *)
 463       remove_file
 464         (Filename.chop_suffix (Filename.basename prim_name) ".c" ^ ".obj");
 465       if retcode <> 0
 466       then retcode
 467       else Ccomp.merge_manifest exec_name
 468   | _ -> assert false
 469
 470 let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
 471   let oc = open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in
 472   let ic = open_in_bin bytecode_name in
 473   copy_file ic oc;
 474   close_in ic;
 475   close_out oc;
 476   remove_file bytecode_name;
 477   remove_file prim_name
 478
 479 (* Fix the name of the output file, if the C compiler changes it behind
 480    our back. *)
 481
 482 let fix_exec_name name =
 483   match Sys.os_type with
 484     "Win32" | "Cygwin" ->
 485       if String.contains name '.' then name else name ^ ".exe"
 486   | _ -> name
 487
 488 (* Main entry point (build a custom runtime if needed) *)
 489
 490 let link objfiles output_name =
 491   let objfiles =
 492     if !Clflags.nopervasives then objfiles
 493     else if !Clflags.output_c_object then "stdlib.cma" :: objfiles
 494     else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in
 495   let tolink = List.fold_right scan_file objfiles [] in
 496   Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *)
 497   Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *)
 498   Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *)
 499   if not !Clflags.custom_runtime then
 500     link_bytecode tolink output_name true
 501   else if not !Clflags.output_c_object then begin
 502     let bytecode_name = Filename.temp_file "camlcode" "" in
 503     let prim_name = Filename.temp_file "camlprim" ".c" in
 504     try
 505       link_bytecode tolink bytecode_name false;
 506       let poc = open_out prim_name in
 507       Symtable.output_primitive_table poc;
 508       close_out poc;
 509       let exec_name = fix_exec_name output_name in
 510       if build_custom_runtime prim_name exec_name <> 0
 511       then raise(Error Custom_runtime);
 512       if !Clflags.make_runtime
 513       then (remove_file bytecode_name; remove_file prim_name)
 514       else append_bytecode_and_cleanup bytecode_name exec_name prim_name
 515     with x ->
 516       remove_file bytecode_name;
 517       remove_file prim_name;
 518       raise x
 519   end else begin
 520     let c_file =
 521       Filename.chop_suffix output_name Config.ext_obj ^ ".c" in
 522     if Sys.file_exists c_file then raise(Error(File_exists c_file));
 523     try
 524       link_bytecode_as_c tolink c_file;
 525       if Ccomp.compile_file c_file <> 0
 526       then raise(Error Custom_runtime);
 527       remove_file c_file
 528     with x ->
 529       remove_file c_file;
 530       remove_file output_name;
 531       raise x
 532   end
 533
 534 (* Error report *)
 535
 536 open Format
 537
 538 let report_error ppf = function
 539   | File_not_found name ->
 540       fprintf ppf "Cannot find file %s" name
 541   | Not_an_object_file name ->
 542       fprintf ppf "The file %s is not a bytecode object file" name
 543   | Symbol_error(name, err) ->
 544       fprintf ppf "Error while linking %s:@ %a" name
 545       Symtable.report_error err
 546   | Inconsistent_import(intf, file1, file2) ->
 547       fprintf ppf
 548         "@[<hov>Files %s@ and %s@ \
 549                  make inconsistent assumptions over interface %s@]"
 550         file1 file2 intf
 551   | Custom_runtime ->
 552       fprintf ppf "Error while building custom runtime system"
 553   | File_exists file ->
 554       fprintf ppf "Cannot overwrite existing file %s" file
 555   | Cannot_open_dll file ->
 556       fprintf ppf "Error on dynamically loaded library: %s" file