l4/pkg/ocaml/contrib/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: compilenv.ml 8477 2007-11-06 15:16:56Z frisch $ *)
  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 let read_library_info filename =
 130   let ic = open_in_bin filename in
 131   let buffer = String.create (String.length cmxa_magic_number) in
 132   really_input ic buffer 0 (String.length cmxa_magic_number);
 133   if buffer <> cmxa_magic_number then
 134     raise(Error(Not_a_unit_info filename));
 135   let infos = (input_value ic : library_infos) in
 136   close_in ic;
 137   infos
 138
 139
 140 (* Read and cache info on global identifiers *)
 141
 142 let cmx_not_found_crc =
 143   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
 144
 145 let get_global_info global_ident =
 146   let modname = Ident.name global_ident in
 147   if modname = current_unit.ui_name then
 148     Some current_unit
 149   else begin
 150     try
 151       Hashtbl.find global_infos_table modname
 152     with Not_found ->
 153       let (infos, crc) =
 154         try
 155           let filename =
 156             find_in_path_uncap !load_path (modname ^ ".cmx") in
 157           let (ui, crc) = read_unit_info filename in
 158           if ui.ui_name <> modname then
 159             raise(Error(Illegal_renaming(ui.ui_name, filename)));
 160           (Some ui, crc)
 161         with Not_found ->
 162           (None, cmx_not_found_crc) in
 163       current_unit.ui_imports_cmx <-
 164         (modname, crc) :: current_unit.ui_imports_cmx;
 165       Hashtbl.add global_infos_table modname infos;
 166       infos
 167   end
 168
 169 let cache_unit_info ui =
 170   Hashtbl.add global_infos_table ui.ui_name (Some ui)
 171
 172 (* Return the approximation of a global identifier *)
 173
 174 let toplevel_approx = Hashtbl.create 16
 175
 176 let record_global_approx_toplevel id =
 177   Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx
 178
 179 let global_approx id =
 180   if Ident.is_predef_exn id then Value_unknown
 181   else try Hashtbl.find toplevel_approx (Ident.name id)
 182   with Not_found ->
 183     match get_global_info id with
 184       | None -> Value_unknown
 185       | Some ui -> ui.ui_approx
 186
 187 (* Return the symbol used to refer to a global identifier *)
 188
 189 let symbol_for_global id =
 190   if Ident.is_predef_exn id then
 191     "caml_exn_" ^ Ident.name id
 192   else begin
 193     match get_global_info id with
 194     | None -> make_symbol ~unitname:(Ident.name id) None
 195     | Some ui -> make_symbol ~unitname:ui.ui_symbol None
 196   end
 197
 198 (* Register the approximation of the module being compiled *)
 199
 200 let set_global_approx approx =
 201   current_unit.ui_approx <- approx
 202
 203 (* Record that a currying function or application function is needed *)
 204
 205 let need_curry_fun n =
 206   if not (List.mem n current_unit.ui_curry_fun) then
 207     current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
 208
 209 let need_apply_fun n =
 210   if not (List.mem n current_unit.ui_apply_fun) then
 211     current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun
 212
 213 let need_send_fun n =
 214   if not (List.mem n current_unit.ui_send_fun) then
 215     current_unit.ui_send_fun <- n :: current_unit.ui_send_fun
 216
 217 (* Write the description of the current unit *)
 218
 219 let write_unit_info info filename =
 220   let oc = open_out_bin filename in
 221   output_string oc cmx_magic_number;
 222   output_value oc info;
 223   flush oc;
 224   let crc = Digest.file filename in
 225   Digest.output oc crc;
 226   close_out oc
 227
 228 let save_unit_info filename =
 229   current_unit.ui_imports_cmi <- Env.imported_units();
 230   write_unit_info current_unit filename
 231
 232 (* Error report *)
 233
 234 open Format
 235
 236 let report_error ppf = function
 237   | Not_a_unit_info filename ->
 238       fprintf ppf "%s@ is not a compilation unit description." filename
 239   | Corrupted_unit_info filename ->
 240       fprintf ppf "Corrupted compilation unit description@ %s" filename
 241   | Illegal_renaming(modname, filename) ->
 242       fprintf ppf "%s@ contains the description for unit@ %s" filename modname
 243