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