(* Link a set of .cmo files and produce a bytecode executable. *)

open Sys
open Misc
open Config
open Emitcode

type error =
    File_not_found of string
  | Not_an_object_file of string
  | Symbol_error of string * Symtable.error
  | Inconsistent_import of string * string * string
  | Custom_runtime

exception Error of error

type link_action =
    Link_object of string * compilation_unit
      (* Name of .cmo file and descriptor of the unit *)
  | Link_archive of string * compilation_unit list
      (* Name of .cma file and descriptors of the units to be linked. *)

(* First pass: determine which units are needed *)

let missing_globals = ref (Cset.empty : Ident.t Cset.t)

let is_required (rel, pos) =
  match rel with
    Reloc_setglobal id -> Cset.mem id !missing_globals
  | _ -> false

let add_required (rel, pos) =
  match rel with
    Reloc_getglobal id -> missing_globals := Cset.add id !missing_globals
  | _ -> ()

let remove_required (rel, pos) =
  match rel with
    Reloc_setglobal id -> missing_globals := Cset.remove id !missing_globals
  | _ -> ()

let scan_file tolink obj_name =
  let file_name =
    try
      find_in_path !load_path obj_name
    with Not_found ->
      raise(Error(File_not_found obj_name)) in
  let ic = open_in_bin file_name in
  try
    let buffer = String.create (String.length cmo_magic_number) in
    really_input ic buffer 0 (String.length cmo_magic_number);
    if buffer = cmo_magic_number then begin
      (* This is a .cmo file. It must be linked in any case.
         Read the relocation information to see which modules it
         requires. *)
      let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
      seek_in ic compunit_pos;
      let compunit = (input_value ic : compilation_unit) in
      List.iter add_required compunit.cu_reloc;
      Link_object(file_name, compunit) :: tolink
    end
    else if buffer = cma_magic_number then begin
      (* This is an archive file. Each unit contained in it will be linked
         in only if needed. *)
      let pos_toc = input_binary_int ic in    (* Go to table of contents *)
      seek_in ic pos_toc;
      let toc = (input_value ic : compilation_unit list) in
      let required =
        List.fold_left
          (fun reqd compunit ->
            if List.exists is_required compunit.cu_reloc
            or !Clflags.link_everything
            then begin
              List.iter remove_required compunit.cu_reloc;
              List.iter add_required compunit.cu_reloc;
              compunit :: reqd
            end else
              reqd)
          [] toc in
      Link_archive(file_name, required) :: tolink
    end
    else raise(Error(Not_an_object_file file_name))
  with x ->
    close_in ic; raise x

(* Second pass: link in the required units *)

(* Consistency check between interfaces *)

let crc_interfaces = (Hashtbl.new 17 : (string, string * int) Hashtbl.t)

let check_consistency file_name cu =
  List.iter
    (fun (name, crc) ->
      try
        let (auth_name, auth_crc) = Hashtbl.find crc_interfaces name in
        if crc <> auth_crc then
          raise(Error(Inconsistent_import(name, file_name, auth_name)))
      with Not_found ->
        Hashtbl.add crc_interfaces name (file_name, crc))
    cu.cu_interfaces

(* Link in a compilation unit *)

let link_compunit outchan inchan file_name compunit =
  check_consistency file_name compunit;
  seek_in inchan compunit.cu_pos;
  let code_block = String.create compunit.cu_codesize in
  really_input inchan code_block 0 compunit.cu_codesize;
  Symtable.patch_object code_block compunit.cu_reloc;
  output outchan code_block 0 compunit.cu_codesize

(* Link in a .cmo file *)

let link_object outchan file_name compunit =
  let inchan = open_in_bin file_name in
  try
    link_compunit outchan inchan file_name compunit;
    close_in inchan
  with
    Symtable.Error msg ->
      close_in inchan; raise(Error(Symbol_error(file_name, msg)))
  | x ->
      close_in inchan; raise x

(* Link in a .cma file *)

let link_archive outchan file_name units_required =
  let inchan = open_in_bin file_name in
  try
    List.iter (link_compunit outchan inchan file_name) units_required;
    close_in inchan
  with
    Symtable.Error msg ->
      close_in inchan; raise(Error(Symbol_error(file_name, msg)))
  | x ->
      close_in inchan; raise x

(* Link in a .cmo or .cma file *)

let link_file outchan = function
    Link_object(file_name, unit) -> link_object outchan file_name unit
  | Link_archive(file_name, units) -> link_archive outchan file_name units

(* Create a bytecode executable file *)

let link_bytecode objfiles exec_name copy_header =
  let objfiles = "stdlib.cma" :: objfiles in
  let tolink =
    List.fold_left scan_file [] (List.rev objfiles) in
  let outchan =
    open_out_gen [Sys.Open_wronly; Sys.Open_trunc; Sys.Open_creat; Sys.Open_binary] 0o777 exec_name in
  try
    (* Copy the header *)
    if copy_header then begin
      try
        let inchan = open_in_bin (find_in_path !load_path "header_exe") in
        copy_file inchan outchan;
        close_in inchan
      with Not_found | Sys_error _ -> ()
    end;
    (* The bytecode *)
    let pos1 = pos_out outchan in
    Symtable.init();
    Hashtbl.clear crc_interfaces;
    List.iter (link_file outchan) tolink;
    (* The final STOP instruction *)
    output_byte outchan Opcodes.opSTOP;
    output_byte outchan 0; output_byte outchan 0; output_byte outchan 0;
    (* The table of global data *)
    let pos2 = pos_out outchan in
    output_compact_value outchan (Symtable.initial_global_table());
    (* The List.map of global identifiers *)
    let pos3 = pos_out outchan in
    Symtable.output_global_map outchan;
    (* The trailer *)
    let pos4 = pos_out outchan in
    output_binary_int outchan (pos2 - pos1);
    output_binary_int outchan (pos3 - pos2);
    output_binary_int outchan (pos4 - pos3);
    output_binary_int outchan 0;
    output_string outchan exec_magic_number;
    close_out outchan
  with x ->
    close_out outchan;
    remove_file exec_name;
    raise x

(* Main entry point (build a custom runtime if needed) *)

let link objfiles =
  if not !Clflags.custom_runtime then
    link_bytecode objfiles !Clflags.exec_name true
  else begin
    let bytecode_name = temp_file "camlcode" "" in
    let prim_name = temp_file "camlprim" ".c" in
    try
      link_bytecode objfiles bytecode_name false;
      Symtable.output_primitives prim_name;
      if Sys.command
          (concat_strings " " (
            Config.c_compiler ::
            ("-I" ^ Config.standard_library) ::
            "-o" :: !Clflags.exec_name ::
            List.rev !Clflags.ccopts @
            prim_name ::
            ("-L" ^ Config.standard_library) ::
            List.rev !Clflags.ccobjs @
            "-lcamlrun" ::
            Config.c_libraries ::
            [])) <> 0 
      or Sys.command ("strip " ^ !Clflags.exec_name) <> 0
      then raise(Error Custom_runtime);
      let oc =
        open_out_gen [Sys.Open_wronly; Sys.Open_append; Sys.Open_binary] 0 !Clflags.exec_name in
      let ic = open_in_bin bytecode_name in
      copy_file ic oc;
      close_in ic;
      close_out oc;
      remove_file bytecode_name;
      remove_file prim_name
    with x ->
      remove_file bytecode_name;
      remove_file prim_name;
      raise x
  end

(* Error report *)

open Format

let report_error = function
    File_not_found name ->
      print_string "Cannot find file "; print_string name
  | Not_an_object_file name ->
      print_string "The file "; print_string name;
      print_string " is not a bytecode object file"
  | Symbol_error(name, err) ->
      print_string "Error while linking "; print_string name; print_string ":";
      print_space();
      Symtable.report_error err
  | Inconsistent_import(intf, file1, file2) ->
      open_hvbox 0;
      print_string "Files "; print_string file1; print_string " and ";
      print_string file2; print_space();
      print_string "make inconsistent assumptions over interface ";
      print_string intf;
      close_box()
  | Custom_runtime ->
      print_string "Error while building custom runtime system"