asmcomp/asmpackager.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 .cmx/.o files into one .cmx/.o file having the
  16    original compilation units as sub-modules. *)
  17
  18 open Printf
  19 open Misc
  20 open Lambda
  21 open Clambda
  22 open Compilenv
  23
  24 type error =
  25     Illegal_renaming of string * string
  26   | Forward_reference of string * string
  27   | Wrong_for_pack of string * string
  28   | Linking_error
  29   | Assembler_error of string
  30   | File_not_found of string
  31
  32
  33 exception Error of error
  34
  35 (* Read the unit information from a .cmx file. *)
  36
  37 type pack_member_kind = PM_intf | PM_impl of unit_infos
  38
  39 type pack_member =
  40   { pm_file: string;
  41     pm_name: string;
  42     pm_kind: pack_member_kind }
  43
  44 let read_member_info pack_path file =
  45   let name =
  46     String.capitalize(Filename.basename(chop_extensions file)) in
  47   let kind =
  48     if Filename.check_suffix file ".cmx" then begin
  49       let (info, crc) = Compilenv.read_unit_info file in
  50       if info.ui_name <> name
  51       then raise(Error(Illegal_renaming(file, info.ui_name)));
  52       if info.ui_symbol <>
  53          (Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name
  54       then raise(Error(Wrong_for_pack(file, pack_path)));
  55       Asmlink.check_consistency file info crc;
  56       Compilenv.cache_unit_info info;
  57       PM_impl info
  58     end else
  59       PM_intf in
  60   { pm_file = file; pm_name = name; pm_kind = kind }
  61
  62 (* Check absence of forward references *)
  63
  64 let check_units members =
  65   let rec check forbidden = function
  66     [] -> ()
  67   | mb :: tl ->
  68       begin match mb.pm_kind with
  69       | PM_intf -> ()
  70       | PM_impl infos ->
  71           List.iter
  72             (fun (unit, _) ->
  73               if List.mem unit forbidden
  74               then raise(Error(Forward_reference(mb.pm_file, unit))))
  75             infos.ui_imports_cmx
  76       end;
  77       check (list_remove mb.pm_name forbidden) tl in
  78   check (List.map (fun mb -> mb.pm_name) members) members
  79
  80 (* Make the .o file for the package *)
  81
  82 let make_package_object ppf members targetobj targetname coercion =
  83   (* Put the full name of the module in the temporary file name
  84      to avoid collisions with MSVC's link /lib in case of successive packs *)
  85   let objtemp =
  86     Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in
  87   let components =
  88     List.map
  89       (fun m ->
  90         match m.pm_kind with
  91         | PM_intf -> None
  92         | PM_impl _ -> Some(Ident.create_persistent m.pm_name))
  93       members in
  94   Asmgen.compile_implementation
  95     (chop_extension_if_any objtemp) ppf
  96     (Translmod.transl_store_package
  97        components (Ident.create_persistent targetname) coercion);
  98   let objfiles =
  99     List.map
 100       (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj)
 101       (List.filter (fun m -> m.pm_kind <> PM_intf) members) in
 102   let ld_cmd =
 103     sprintf "%s%s %s %s"
 104             Config.native_pack_linker
 105             (Filename.quote targetobj)
 106             (Filename.quote objtemp)
 107             (Ccomp.quote_files objfiles) in
 108   let retcode = Ccomp.command ld_cmd in
 109   remove_file objtemp;
 110   if retcode <> 0 then raise(Error Linking_error)
 111
 112 (* Make the .cmx file for the package *)
 113
 114 let build_package_cmx members cmxfile =
 115   let unit_names =
 116     List.map (fun m -> m.pm_name) members in
 117   let filter lst =
 118     List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
 119   let union lst =
 120     List.fold_left
 121       (List.fold_left
 122           (fun accu n -> if List.mem n accu then accu else n :: accu))
 123       [] lst in
 124   let units =
 125     List.fold_right
 126       (fun m accu ->
 127         match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu)
 128       members [] in
 129   let ui = Compilenv.current_unit_infos() in
 130   let pkg_infos =
 131     { ui_name = ui.ui_name;
 132       ui_symbol = ui.ui_symbol;
 133       ui_defines =
 134           List.flatten (List.map (fun info -> info.ui_defines) units) @
 135           [ui.ui_symbol];
 136       ui_imports_cmi =
 137           (ui.ui_name, Env.crc_of_unit ui.ui_name) ::
 138           filter(Asmlink.extract_crc_interfaces());
 139       ui_imports_cmx =
 140           filter(Asmlink.extract_crc_implementations());
 141       ui_approx = ui.ui_approx;
 142       ui_curry_fun =
 143           union(List.map (fun info -> info.ui_curry_fun) units);
 144       ui_apply_fun =
 145           union(List.map (fun info -> info.ui_apply_fun) units);
 146       ui_send_fun =
 147           union(List.map (fun info -> info.ui_send_fun) units);
 148       ui_force_link =
 149           List.exists (fun info -> info.ui_force_link) units
 150     } in
 151   Compilenv.write_unit_info pkg_infos cmxfile
 152
 153 (* Make the .cmx and the .o for the package *)
 154
 155 let package_object_files ppf files targetcmx
 156                          targetobj targetname coercion =
 157   let pack_path =
 158     match !Clflags.for_package with
 159     | None -> targetname
 160     | Some p -> p ^ "." ^ targetname in
 161   let members = map_left_right (read_member_info pack_path) files in
 162   check_units members;
 163   make_package_object ppf members targetobj targetname coercion;
 164   build_package_cmx members targetcmx
 165
 166 (* The entry point *)
 167
 168 let package_files ppf files targetcmx =
 169   let files =
 170     List.map
 171       (fun f ->
 172         try find_in_path !Config.load_path f
 173         with Not_found -> raise(Error(File_not_found f)))
 174       files in
 175   let prefix = chop_extensions targetcmx in
 176   let targetcmi = prefix ^ ".cmi" in
 177   let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in
 178   let targetname = String.capitalize(Filename.basename prefix) in
 179   (* Set the name of the current "input" *)
 180   Location.input_name := targetcmx;
 181   (* Set the name of the current compunit *)
 182   Compilenv.reset ?packname:!Clflags.for_package targetname;
 183   try
 184     let coercion = Typemod.package_units files targetcmi targetname in
 185     package_object_files ppf files targetcmx targetobj targetname coercion
 186   with x ->
 187     remove_file targetcmx; remove_file targetobj;
 188     raise x
 189
 190 (* Error report *)
 191
 192 open Format
 193
 194 let report_error ppf = function
 195     Illegal_renaming(file, id) ->
 196       fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
 197         file id
 198   | Forward_reference(file, ident) ->
 199       fprintf ppf "Forward reference to %s in file %s" ident file
 200   | Wrong_for_pack(file, path) ->
 201       fprintf ppf "File %s@ was not compiled with the `-for-pack %s' option"
 202               file path
 203   | File_not_found file ->
 204       fprintf ppf "File %s not found" file
 205   | Assembler_error file ->
 206       fprintf ppf "Error while assembling %s" file
 207   | Linking_error ->
 208       fprintf ppf "Error during partial linking"