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