bytecomp/bytepackager.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2002 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 (* "Package" a set of .cmo files into one .cmo file having the
  16    original compilation units as sub-modules. *)
  17
  18 open Misc
  19 open Instruct
  20 open Cmo_format
  21
  22 type error =
  23     Forward_reference of string * Ident.t
  24   | Multiple_definition of string * Ident.t
  25   | Not_an_object_file of string
  26   | Illegal_renaming of string * string
  27   | File_not_found of string
  28
  29 exception Error of error
  30
  31 (* References accumulating informations on the .cmo files *)
  32
  33 let relocs = ref ([] : (reloc_info * int) list)
  34 let events = ref ([] : debug_event list)
  35 let primitives = ref ([] : string list)
  36 let force_link = ref false
  37
  38 (* Record a relocation.  Update its offset, and rename GETGLOBAL and
  39    SETGLOBAL relocations that correspond to one of the units being
  40    consolidated. *)
  41
  42 let rename_relocation objfile mapping defined base (rel, ofs) =
  43   let rel' =
  44     match rel with
  45       Reloc_getglobal id ->
  46         begin try
  47           let id' = List.assoc id mapping in
  48           if List.mem id defined
  49           then Reloc_getglobal id'
  50           else raise(Error(Forward_reference(objfile, id)))
  51         with Not_found ->
  52           rel
  53         end
  54     | Reloc_setglobal id ->
  55         begin try
  56           let id' = List.assoc id mapping in
  57           if List.mem id defined
  58           then raise(Error(Multiple_definition(objfile, id)))
  59           else Reloc_setglobal id'
  60         with Not_found ->
  61           rel
  62         end
  63     | _ ->
  64         rel in
  65   relocs := (rel', base + ofs) :: !relocs
  66
  67 (* Record and relocate a debugging event *)
  68
  69 let relocate_debug base ev =
  70   ev.ev_pos <- base + ev.ev_pos;
  71   events := ev :: !events
  72
  73 (* Read the unit information from a .cmo file. *)
  74
  75 type pack_member_kind = PM_intf | PM_impl of compilation_unit
  76
  77 type pack_member =
  78   { pm_file: string;
  79     pm_name: string;
  80     pm_kind: pack_member_kind }
  81
  82 let read_member_info file =
  83   let name =
  84     String.capitalize(Filename.basename(chop_extensions file)) in
  85   let kind =
  86     if Filename.check_suffix file ".cmo" then begin
  87     let ic = open_in_bin file in
  88     try
  89       let buffer = String.create (String.length Config.cmo_magic_number) in
  90       really_input ic buffer 0 (String.length Config.cmo_magic_number);
  91       if buffer <> Config.cmo_magic_number then
  92         raise(Error(Not_an_object_file file));
  93       let compunit_pos = input_binary_int ic in
  94       seek_in ic compunit_pos;
  95       let compunit = (input_value ic : compilation_unit) in
  96       if compunit.cu_name <> name
  97       then raise(Error(Illegal_renaming(file, compunit.cu_name)));
  98       close_in ic;
  99       PM_impl compunit
 100     with x ->
 101       close_in ic;
 102       raise x
 103     end else
 104       PM_intf in
 105   { pm_file = file; pm_name = name; pm_kind = kind }
 106
 107 (* Read the bytecode from a .cmo file.
 108    Write bytecode to channel [oc].
 109    Rename globals as indicated by [mapping] in reloc info.
 110    Accumulate relocs, debug info, etc.
 111    Return size of bytecode. *)
 112
 113 let rename_append_bytecode oc mapping defined ofs objfile compunit =
 114   let ic = open_in_bin objfile in
 115   try
 116     Bytelink.check_consistency objfile compunit;
 117     List.iter
 118       (rename_relocation objfile mapping defined ofs)
 119       compunit.cu_reloc;
 120     primitives := compunit.cu_primitives @ !primitives;
 121     if compunit.cu_force_link then force_link := true;
 122     seek_in ic compunit.cu_pos;
 123     Misc.copy_file_chunk ic oc compunit.cu_codesize;
 124     if !Clflags.debug && compunit.cu_debug > 0 then begin
 125       seek_in ic compunit.cu_debug;
 126       List.iter (relocate_debug ofs) (input_value ic);
 127     end;
 128     close_in ic;
 129     compunit.cu_codesize
 130   with x ->
 131     close_in ic;
 132     raise x
 133
 134 (* Same, for a list of .cmo and .cmi files.
 135    Return total size of bytecode. *)
 136
 137 let rec rename_append_bytecode_list oc mapping defined ofs = function
 138     [] ->
 139       ofs
 140   | m :: rem ->
 141       match m.pm_kind with
 142       | PM_intf ->
 143           rename_append_bytecode_list oc mapping defined ofs rem
 144       | PM_impl compunit ->
 145           let size =
 146             rename_append_bytecode oc mapping defined ofs
 147                                    m.pm_file compunit in
 148           rename_append_bytecode_list
 149             oc mapping (Ident.create_persistent m.pm_name :: defined)
 150             (ofs + size) rem
 151
 152 (* Generate the code that builds the tuple representing the package module *)
 153
 154 let build_global_target oc target_name members mapping pos coercion =
 155   let components =
 156     List.map2
 157       (fun m (id1, id2) ->
 158         match m.pm_kind with
 159         | PM_intf -> None
 160         | PM_impl _ -> Some id2)
 161       members mapping in
 162   let lam =
 163     Translmod.transl_package
 164       components (Ident.create_persistent target_name) coercion in
 165   let instrs =
 166     Bytegen.compile_implementation target_name lam in
 167   let rel =
 168     Emitcode.to_packed_file oc instrs in
 169   relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs
 170
 171 (* Build the .cmo file obtained by packaging the given .cmo files. *)
 172
 173 let package_object_files files targetfile targetname coercion =
 174   let members =
 175     map_left_right read_member_info files in
 176   let unit_names =
 177     List.map (fun m -> m.pm_name) members in
 178   let mapping =
 179     List.map
 180       (fun name ->
 181           (Ident.create_persistent name,
 182            Ident.create_persistent(targetname ^ "." ^ name)))
 183       unit_names in
 184   let oc = open_out_bin targetfile in
 185   try
 186     output_string oc Config.cmo_magic_number;
 187     let pos_depl = pos_out oc in
 188     output_binary_int oc 0;
 189     let pos_code = pos_out oc in
 190     let ofs = rename_append_bytecode_list oc mapping [] 0 members in
 191     build_global_target oc targetname members mapping ofs coercion;
 192     let pos_debug = pos_out oc in
 193     if !Clflags.debug && !events <> [] then
 194       output_value oc (List.rev !events);
 195     let pos_final = pos_out oc in
 196     let imports =
 197       List.filter
 198         (fun (name, crc) -> not (List.mem name unit_names))
 199         (Bytelink.extract_crc_interfaces()) in
 200     let compunit =
 201       { cu_name = targetname;
 202         cu_pos = pos_code;
 203         cu_codesize = pos_debug - pos_code;
 204         cu_reloc = List.rev !relocs;
 205         cu_imports = (targetname, Env.crc_of_unit targetname) :: imports;
 206         cu_primitives = !primitives;
 207         cu_force_link = !force_link;
 208         cu_debug = if pos_final > pos_debug then pos_debug else 0;
 209         cu_debugsize = pos_final - pos_debug } in
 210     output_value oc compunit;
 211     seek_out oc pos_depl;
 212     output_binary_int oc pos_final;
 213     close_out oc
 214   with x ->
 215     close_out oc;
 216     raise x
 217
 218 (* The entry point *)
 219
 220 let package_files files targetfile =
 221   let files =
 222     List.map
 223       (fun f ->
 224         try find_in_path !Config.load_path f
 225         with Not_found -> raise(Error(File_not_found f)))
 226       files in
 227   let prefix = chop_extensions targetfile in
 228   let targetcmi = prefix ^ ".cmi" in
 229   let targetname = String.capitalize(Filename.basename prefix) in
 230   try
 231     let coercion = Typemod.package_units files targetcmi targetname in
 232     package_object_files files targetfile targetname coercion
 233   with x ->
 234     remove_file targetfile; raise x
 235
 236 (* Error report *)
 237
 238 open Format
 239
 240 let report_error ppf = function
 241     Forward_reference(file, ident) ->
 242       fprintf ppf "Forward reference to %s in file %s" (Ident.name ident) file
 243   | Multiple_definition(file, ident) ->
 244       fprintf ppf "File %s redefines %s" file (Ident.name ident)
 245   | Not_an_object_file file ->
 246       fprintf ppf "%s is not a bytecode object file" file
 247   | Illegal_renaming(file, id) ->
 248       fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
 249         file id
 250   | File_not_found file ->
 251       fprintf ppf "File %s not found" file