otherlibs/dynlink/dynlink.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 GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../../LICENSE.  *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id$ *)
  15
  16 (* Dynamic loading of .cmo files *)
  17
  18 open Dynlinkaux
  19 open Dynlinkaux.Cmo_format
  20
  21 type linking_error =
  22     Undefined_global of string
  23   | Unavailable_primitive of string
  24   | Uninitialized_global of string
  25
  26 type error =
  27     Not_a_bytecode_file of string
  28   | Inconsistent_import of string
  29   | Unavailable_unit of string
  30   | Unsafe_file
  31   | Linking_error of string * linking_error
  32   | Corrupted_interface of string
  33   | File_not_found of string
  34   | Cannot_open_dll of string
  35
  36 exception Error of error
  37
  38 (* Management of interface CRCs *)
  39
  40 let crc_interfaces = ref (Consistbl.create ())
  41 let allow_extension = ref true
  42
  43 (* Check that the object file being loaded has been compiled against
  44    the same interfaces as the program itself. In addition, check that
  45    only authorized compilation units are referenced. *)
  46
  47 let check_consistency file_name cu =
  48   try
  49     List.iter
  50       (fun (name, crc) ->
  51         if name = cu.cu_name then
  52           Consistbl.set !crc_interfaces name crc file_name
  53         else if !allow_extension then
  54           Consistbl.check !crc_interfaces name crc file_name
  55         else
  56           Consistbl.check_noadd !crc_interfaces name crc file_name)
  57       cu.cu_imports
  58   with Consistbl.Inconsistency(name, user, auth) ->
  59          raise(Error(Inconsistent_import name))
  60      | Consistbl.Not_available(name) ->
  61          raise(Error(Unavailable_unit name))
  62
  63 (* Empty the crc_interfaces table *)
  64
  65 let clear_available_units () =
  66   Consistbl.clear !crc_interfaces;
  67   allow_extension := false
  68
  69 (* Allow only access to the units with the given names *)
  70
  71 let allow_only names =
  72   Consistbl.filter (fun name -> List.mem name names) !crc_interfaces;
  73   allow_extension := false
  74
  75 (* Prohibit access to the units with the given names *)
  76
  77 let prohibit names =
  78   Consistbl.filter (fun name -> not (List.mem name names)) !crc_interfaces;
  79   allow_extension := false
  80
  81 (* Initialize the crc_interfaces table with a list of units with fixed CRCs *)
  82
  83 let add_available_units units =
  84   List.iter (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "")
  85             units
  86
  87 (* Default interface CRCs: those found in the current executable *)
  88 let default_crcs = ref []
  89
  90 let default_available_units () =
  91   clear_available_units();
  92   add_available_units !default_crcs;
  93   allow_extension := true
  94
  95 (* Initialize the linker tables and everything *)
  96
  97 let init () =
  98   default_crcs := Symtable.init_toplevel();
  99   default_available_units ()
 100
 101 (* Read the CRC of an interface from its .cmi file *)
 102
 103 let digest_interface unit loadpath =
 104   let filename =
 105     let shortname = unit ^ ".cmi" in
 106     try
 107       Misc.find_in_path_uncap loadpath shortname
 108     with Not_found ->
 109       raise (Error(File_not_found shortname)) in
 110   let ic = open_in_bin filename in
 111   try
 112     let buffer = String.create (String.length Config.cmi_magic_number) in
 113     really_input ic buffer 0 (String.length Config.cmi_magic_number);
 114     if buffer <> Config.cmi_magic_number then begin
 115       close_in ic;
 116       raise(Error(Corrupted_interface filename))
 117     end;
 118     ignore (input_value ic);
 119     let crc =
 120       match input_value ic with
 121         (_, crc) :: _ -> crc
 122       | _             -> raise(Error(Corrupted_interface filename))
 123     in
 124     close_in ic;
 125     crc
 126   with End_of_file | Failure _ ->
 127     close_in ic;
 128     raise(Error(Corrupted_interface filename))
 129
 130 (* Initialize the crc_interfaces table with a list of units.
 131    Their CRCs are read from their interfaces. *)
 132
 133 let add_interfaces units loadpath =
 134   add_available_units
 135     (List.map (fun unit -> (unit, digest_interface unit loadpath)) units)
 136
 137 (* Check whether the object file being loaded was compiled in unsafe mode *)
 138
 139 let unsafe_allowed = ref false
 140
 141 let allow_unsafe_modules b =
 142   unsafe_allowed := b
 143
 144 let check_unsafe_module cu =
 145   if (not !unsafe_allowed) && cu.cu_primitives <> []
 146   then raise(Error(Unsafe_file))
 147
 148 (* Load in-core and execute a bytecode object file *)
 149
 150 let load_compunit ic file_name compunit =
 151   check_consistency file_name compunit;
 152   check_unsafe_module compunit;
 153   seek_in ic compunit.cu_pos;
 154   let code_size = compunit.cu_codesize + 8 in
 155   let code = Meta.static_alloc code_size in
 156   unsafe_really_input ic code 0 compunit.cu_codesize;
 157   String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN);
 158   String.unsafe_set code (compunit.cu_codesize + 1) '\000';
 159   String.unsafe_set code (compunit.cu_codesize + 2) '\000';
 160   String.unsafe_set code (compunit.cu_codesize + 3) '\000';
 161   String.unsafe_set code (compunit.cu_codesize + 4) '\001';
 162   String.unsafe_set code (compunit.cu_codesize + 5) '\000';
 163   String.unsafe_set code (compunit.cu_codesize + 6) '\000';
 164   String.unsafe_set code (compunit.cu_codesize + 7) '\000';
 165   let initial_symtable = Symtable.current_state() in
 166   begin try
 167     Symtable.patch_object code compunit.cu_reloc;
 168     Symtable.check_global_initialized compunit.cu_reloc;
 169     Symtable.update_global_table()
 170   with Symtable.Error error ->
 171     let new_error =
 172       match error with
 173         Symtable.Undefined_global s -> Undefined_global s
 174       | Symtable.Unavailable_primitive s -> Unavailable_primitive s
 175       | Symtable.Uninitialized_global s -> Uninitialized_global s
 176       | _ -> assert false in
 177     raise(Error(Linking_error (file_name, new_error)))
 178   end;
 179   begin try
 180     ignore((Meta.reify_bytecode code code_size) ())
 181   with exn ->
 182     Symtable.restore_state initial_symtable;
 183     raise exn
 184   end
 185
 186 let loadfile file_name =
 187   let ic = open_in_bin file_name in
 188   try
 189     let buffer = String.create (String.length Config.cmo_magic_number) in
 190     really_input ic buffer 0 (String.length Config.cmo_magic_number);
 191     if buffer = Config.cmo_magic_number then begin
 192       let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
 193       seek_in ic compunit_pos;
 194       load_compunit ic file_name (input_value ic : compilation_unit)
 195     end else
 196     if buffer = Config.cma_magic_number then begin
 197       let toc_pos = input_binary_int ic in  (* Go to table of contents *)
 198       seek_in ic toc_pos;
 199       let lib = (input_value ic : library) in
 200       begin try
 201         Dll.open_dlls Dll.For_execution
 202                       (List.map Dll.extract_dll_name lib.lib_dllibs)
 203       with Failure reason ->
 204         raise(Error(Cannot_open_dll reason))
 205       end;
 206       List.iter (load_compunit ic file_name) lib.lib_units
 207     end else
 208       raise(Error(Not_a_bytecode_file file_name));
 209     close_in ic
 210   with exc ->
 211     close_in ic; raise exc
 212
 213 let loadfile_private file_name =
 214   let initial_symtable = Symtable.current_state()
 215   and initial_crc = !crc_interfaces in
 216   try
 217     loadfile file_name;
 218     Symtable.hide_additions initial_symtable;
 219     crc_interfaces := initial_crc
 220   with exn ->
 221     Symtable.hide_additions initial_symtable;
 222     crc_interfaces := initial_crc;
 223     raise exn
 224
 225 (* Error report *)
 226
 227 let error_message = function
 228     Not_a_bytecode_file name ->
 229       name ^ " is not a bytecode object file"
 230   | Inconsistent_import name ->
 231       "interface mismatch on " ^ name
 232   | Unavailable_unit name ->
 233       "no implementation available for " ^ name
 234   | Unsafe_file ->
 235       "this object file uses unsafe features"
 236   | Linking_error (name, Undefined_global s) ->
 237       "error while linking " ^ name ^ ".\n" ^
 238       "Reference to undefined global `" ^ s ^ "'"
 239   | Linking_error (name, Unavailable_primitive s) ->
 240       "error while linking " ^ name ^ ".\n" ^
 241       "The external function `" ^ s ^ "' is not available"
 242   | Linking_error (name, Uninitialized_global s) ->
 243       "error while linking " ^ name ^ ".\n" ^
 244       "The module `" ^ s ^ "' is not yet initialized"
 245   | Corrupted_interface name ->
 246       "corrupted interface file " ^ name
 247   | File_not_found name ->
 248       "cannot find file " ^ name ^ " in search path"
 249   | Cannot_open_dll reason ->
 250       "error loading shared library: " ^ reason