asmcomp/compilenv.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 (* Compilation environments for compilation units *)
  16
  17 open Config
  18 open Misc
  19 open Clambda
  20
  21 type error =
  22     Not_a_unit_info of string
  23   | Corrupted_unit_info of string
  24   | Illegal_renaming of string * string
  25
  26 exception Error of error
  27
  28 (* Each .o file has a matching .cmx file that provides the following infos
  29    on the compilation unit:
  30      - list of other units imported, with CRCs of their .cmx files
  31      - approximation of the structure implemented
  32        (includes descriptions of known functions: arity and direct entry
  33         points)
  34      - list of currying functions and application functions needed
  35    The .cmx file contains these infos (as an externed record) plus a CRC
  36    of these infos *)
  37
  38 type unit_infos =
  39   { mutable ui_name: string;                    (* Name of unit implemented *)
  40     mutable ui_symbol: string;            (* Prefix for symbols *)
  41     mutable ui_defines: string list;      (* Unit and sub-units implemented *)
  42     mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
  43     mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
  44     mutable ui_approx: value_approximation;     (* Approx of the structure *)
  45     mutable ui_curry_fun: int list;             (* Currying functions needed *)
  46     mutable ui_apply_fun: int list;             (* Apply functions needed *)
  47     mutable ui_send_fun: int list;              (* Send functions needed *)
  48     mutable ui_force_link: bool }               (* Always linked *)
  49
  50 (* Each .a library has a matching .cmxa file that provides the following
  51    infos on the library: *)
  52
  53 type library_infos =
  54   { lib_units: (unit_infos * Digest.t) list;  (* List of unit infos w/ CRCs *)
  55     lib_ccobjs: string list;            (* C object files needed *)
  56     lib_ccopts: string list }           (* Extra opts to C compiler *)
  57
  58 let global_infos_table =
  59   (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
  60
  61 let current_unit =
  62   { ui_name = "";
  63     ui_symbol = "";
  64     ui_defines = [];
  65     ui_imports_cmi = [];
  66     ui_imports_cmx = [];
  67     ui_approx = Value_unknown;
  68     ui_curry_fun = [];
  69     ui_apply_fun = [];
  70     ui_send_fun = [];
  71     ui_force_link = false }
  72
  73 let symbolname_for_pack pack name =
  74   match pack with
  75   | None -> name
  76   | Some p ->
  77       let b = Buffer.create 64 in
  78       for i = 0 to String.length p - 1 do
  79         match p.[i] with
  80         | '.' -> Buffer.add_string b "__"
  81         |  c  -> Buffer.add_char b c
  82       done;
  83       Buffer.add_string b "__";
  84       Buffer.add_string b name;
  85       Buffer.contents b
  86
  87 let reset ?packname name =
  88   Hashtbl.clear global_infos_table;
  89   let symbol = symbolname_for_pack packname name in
  90   current_unit.ui_name <- name;
  91   current_unit.ui_symbol <- symbol;
  92   current_unit.ui_defines <- [symbol];
  93   current_unit.ui_imports_cmi <- [];
  94   current_unit.ui_imports_cmx <- [];
  95   current_unit.ui_curry_fun <- [];
  96   current_unit.ui_apply_fun <- [];
  97   current_unit.ui_send_fun <- [];
  98   current_unit.ui_force_link <- false
  99
 100 let current_unit_infos () =
 101   current_unit
 102
 103 let current_unit_name () =
 104   current_unit.ui_name
 105
 106 let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
 107   let prefix = "caml" ^ unitname in
 108   match idopt with
 109   | None -> prefix
 110   | Some id -> prefix ^ "__" ^ id
 111
 112 let read_unit_info filename =
 113   let ic = open_in_bin filename in
 114   try
 115     let buffer = String.create (String.length cmx_magic_number) in
 116     really_input ic buffer 0 (String.length cmx_magic_number);
 117     if buffer <> cmx_magic_number then begin
 118       close_in ic;
 119       raise(Error(Not_a_unit_info filename))
 120     end;
 121     let ui = (input_value ic : unit_infos) in
 122     let crc = Digest.input ic in
 123     close_in ic;
 124     (ui, crc)
 125   with End_of_file | Failure _ ->
 126     close_in ic;
 127     raise(Error(Corrupted_unit_info(filename)))
 128
 129 (* Read and cache info on global identifiers *)
 130
 131 let cmx_not_found_crc =
 132   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
 133
 134 let get_global_info global_ident =
 135   let modname = Ident.name global_ident in
 136   if modname = current_unit.ui_name then
 137     Some current_unit
 138   else begin
 139     try
 140       Hashtbl.find global_infos_table modname
 141     with Not_found ->
 142       let (infos, crc) =
 143         try
 144           let filename =
 145             find_in_path_uncap !load_path (modname ^ ".cmx") in
 146           let (ui, crc) = read_unit_info filename in
 147           if ui.ui_name <> modname then
 148             raise(Error(Illegal_renaming(ui.ui_name, filename)));
 149           (Some ui, crc)
 150         with Not_found ->
 151           (None, cmx_not_found_crc) in
 152       current_unit.ui_imports_cmx <-
 153         (modname, crc) :: current_unit.ui_imports_cmx;
 154       Hashtbl.add global_infos_table modname infos;
 155       infos
 156   end
 157
 158 let cache_unit_info ui =
 159   Hashtbl.add global_infos_table ui.ui_name (Some ui)
 160
 161 (* Return the approximation of a global identifier *)
 162
 163 let global_approx id =
 164   match get_global_info id with
 165   | None -> Value_unknown
 166   | Some ui -> ui.ui_approx
 167
 168 (* Return the symbol used to refer to a global identifier *)
 169
 170 let symbol_for_global id =
 171   if Ident.is_predef_exn id then
 172     "caml_exn_" ^ Ident.name id
 173   else begin
 174     match get_global_info id with
 175     | None -> make_symbol ~unitname:(Ident.name id) None
 176     | Some ui -> make_symbol ~unitname:ui.ui_symbol None
 177   end
 178
 179 (* Register the approximation of the module being compiled *)
 180
 181 let set_global_approx approx =
 182   current_unit.ui_approx <- approx
 183
 184 (* Record that a currying function or application function is needed *)
 185
 186 let need_curry_fun n =
 187   if not (List.mem n current_unit.ui_curry_fun) then
 188     current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
 189
 190 let need_apply_fun n =
 191   if not (List.mem n current_unit.ui_apply_fun) then
 192     current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun
 193
 194 let need_send_fun n =
 195   if not (List.mem n current_unit.ui_send_fun) then
 196     current_unit.ui_send_fun <- n :: current_unit.ui_send_fun
 197
 198 (* Write the description of the current unit *)
 199
 200 let write_unit_info info filename =
 201   let oc = open_out_bin filename in
 202   output_string oc cmx_magic_number;
 203   output_value oc info;
 204   flush oc;
 205   let crc = Digest.file filename in
 206   Digest.output oc crc;
 207   close_out oc
 208
 209 let save_unit_info filename =
 210   current_unit.ui_imports_cmi <- Env.imported_units();
 211   write_unit_info current_unit filename
 212
 213 (* Error report *)
 214
 215 open Format
 216
 217 let report_error ppf = function
 218   | Not_a_unit_info filename ->
 219       fprintf ppf "%s@ is not a compilation unit description." filename
 220   | Corrupted_unit_info filename ->
 221       fprintf ppf "Corrupted compilation unit description@ %s" filename
 222   | Illegal_renaming(modname, filename) ->
 223       fprintf ppf "%s@ contains the description for unit@ %s" filename modname
 224