l4/pkg/ocaml/contrib/otherlibs/dynlink/natdynlink.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Gallium, 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: natdynlink.ml 8993 2008-08-28 22:17:51Z frisch $ *)
  15
  16 (* Dynamic loading of .cmx files *)
  17
  18 type handle
  19
  20 external ndl_open: string -> bool -> handle * string = "caml_natdynlink_open"
  21 external ndl_run: handle -> string -> unit = "caml_natdynlink_run"
  22 external ndl_getmap: unit -> string = "caml_natdynlink_getmap"
  23 external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited"
  24
  25 type linking_error =
  26     Undefined_global of string
  27   | Unavailable_primitive of string
  28   | Uninitialized_global of string
  29
  30 type error =
  31     Not_a_bytecode_file of string
  32   | Inconsistent_import of string
  33   | Unavailable_unit of string
  34   | Unsafe_file
  35   | Linking_error of string * linking_error
  36   | Corrupted_interface of string
  37   | File_not_found of string
  38   | Cannot_open_dll of string
  39   | Inconsistent_implementation of string
  40
  41 exception Error of error
  42
  43 (* Copied from other places to avoid dependencies *)
  44
  45 type dynunit = {
  46   name: string;
  47   crc: Digest.t;
  48   imports_cmi: (string * Digest.t) list;
  49   imports_cmx: (string * Digest.t) list;
  50   defines: string list;
  51 }
  52
  53 type dynheader = {
  54   magic: string;
  55   units: dynunit list;
  56 }
  57
  58 let dyn_magic_number = "Caml2007D001"
  59
  60 let dll_filename fname =
  61   if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname
  62   else fname
  63
  64 let read_file filename priv =
  65   let dll = dll_filename filename in
  66   if not (Sys.file_exists dll) then raise (Error (File_not_found dll));
  67
  68   let (handle,data) as res = ndl_open dll (not priv) in
  69   if Obj.tag (Obj.repr res) = Obj.string_tag
  70   then raise (Error (Cannot_open_dll (Obj.magic res)));
  71
  72   let header : dynheader = Marshal.from_string data 0 in
  73   if header.magic <> dyn_magic_number
  74   then raise(Error(Not_a_bytecode_file dll));
  75   (dll, handle, header.units)
  76
  77 let cmx_not_found_crc =
  78   "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000"
  79
  80
  81 (* Management of interface and implementation CRCs *)
  82
  83 module StrMap = Map.Make(String)
  84
  85 type implem_state =
  86   | Loaded
  87   | Check_inited of int
  88
  89 type state = {
  90   ifaces: (string*string) StrMap.t;
  91   implems: (string*string*implem_state) StrMap.t;
  92 }
  93
  94 let empty_state = {
  95   ifaces = StrMap.empty;
  96   implems = StrMap.empty;
  97 }
  98
  99 let global_state = ref empty_state
 100
 101 let allow_extension = ref true
 102
 103 let inited = ref false
 104
 105 let default_available_units () =
 106   let map : (string*Digest.t*Digest.t*string list) list =
 107     Marshal.from_string (ndl_getmap ()) 0 in
 108   let exe = Sys.executable_name in
 109   let rank = ref 0 in
 110   global_state :=
 111     List.fold_left
 112       (fun st (name,crc_intf,crc_impl,syms) ->
 113         rank := !rank + List.length syms;
 114         {
 115          ifaces = StrMap.add name (crc_intf,exe) st.ifaces;
 116          implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems;
 117         }
 118       )
 119       empty_state
 120       map;
 121   allow_extension := true;
 122   inited := true
 123
 124 let init () =
 125   if not !inited then default_available_units ()
 126
 127 let add_check_ifaces allow_ext filename ui ifaces =
 128   List.fold_left
 129     (fun ifaces (name, crc) ->
 130        if name = ui.name
 131        then StrMap.add name (crc,filename) ifaces
 132        else
 133          try
 134            let (old_crc,old_src) = StrMap.find name ifaces in
 135            if old_crc <> crc
 136            then raise(Error(Inconsistent_import(name)))
 137            else ifaces
 138          with Not_found ->
 139            if allow_ext then StrMap.add name (crc,filename) ifaces
 140            else raise (Error(Unavailable_unit name))
 141     ) ifaces ui.imports_cmi
 142
 143 let check_implems filename ui implems =
 144   List.iter
 145     (fun (name, crc) ->
 146        match name with
 147          |"Out_of_memory"
 148          |"Sys_error"
 149          |"Failure"
 150          |"Invalid_argument"
 151          |"End_of_file"
 152          |"Division_by_zero"
 153          |"Not_found"
 154          |"Match_failure"
 155          |"Stack_overflow"
 156          |"Sys_blocked_io"
 157          |"Assert_failure"
 158          |"Undefined_recursive_module" -> ()
 159          | _ ->
 160        try
 161          let (old_crc,old_src,state) = StrMap.find name implems in
 162          if crc <> cmx_not_found_crc && old_crc <> crc
 163          then raise(Error(Inconsistent_implementation(name)))
 164          else match state with
 165            | Check_inited i ->
 166                if ndl_globals_inited() < i
 167                then raise(Error(Unavailable_unit name))
 168            | Loaded -> ()
 169        with Not_found ->
 170          raise (Error(Unavailable_unit name))
 171     ) ui.imports_cmx
 172
 173 let loadunits filename handle units state =
 174   let new_ifaces =
 175     List.fold_left
 176       (fun accu ui -> add_check_ifaces !allow_extension filename ui accu)
 177       state.ifaces units in
 178   let new_implems =
 179     List.fold_left
 180       (fun accu ui ->
 181          check_implems filename ui accu;
 182          StrMap.add ui.name (ui.crc,filename,Loaded) accu)
 183       state.implems units in
 184
 185   let defines = List.flatten (List.map (fun ui -> ui.defines) units) in
 186
 187   ndl_run handle "_shared_startup";
 188   List.iter (ndl_run handle) defines;
 189   { implems = new_implems; ifaces = new_ifaces }
 190
 191 let load priv filename =
 192   init();
 193   let (filename,handle,units) = read_file filename priv in
 194   let nstate = loadunits filename handle units !global_state in
 195   if not priv then global_state := nstate
 196
 197 let loadfile filename = load false filename
 198 let loadfile_private filename = load true filename
 199
 200 let allow_only names =
 201   init();
 202   let old = !global_state.ifaces in
 203   let ifaces =
 204     List.fold_left
 205       (fun ifaces name ->
 206          try StrMap.add name (StrMap.find name old) ifaces
 207          with Not_found -> ifaces)
 208       StrMap.empty names in
 209   global_state := { !global_state with ifaces = ifaces };
 210   allow_extension := false
 211
 212 let prohibit names =
 213   init();
 214   let ifaces = List.fold_right StrMap.remove names !global_state.ifaces in
 215   global_state := { !global_state with ifaces = ifaces };
 216   allow_extension := false
 217
 218 let digest_interface _ _ =
 219   failwith "Dynlink.digest_interface: not implemented in native code"
 220 let add_interfaces _ _ =
 221   failwith "Dynlink.add_interfaces: not implemented in native code"
 222 let add_available_units _ =
 223   failwith "Dynlink.add_available_units: not implemented in native code"
 224 let clear_available_units _ =
 225   failwith "Dynlink.clear_available_units: not implemented in native code"
 226 let allow_unsafe_modules _ =
 227   ()
 228
 229 (* Error report *)
 230
 231 let error_message = function
 232     Not_a_bytecode_file name ->
 233       name ^ " is not an object file"
 234   | Inconsistent_import name ->
 235       "interface mismatch on " ^ name
 236   | Unavailable_unit name ->
 237       "no implementation available for " ^ name
 238   | Unsafe_file ->
 239       "this object file uses unsafe features"
 240   | Linking_error (name, Undefined_global s) ->
 241       "error while linking " ^ name ^ ".\n" ^
 242       "Reference to undefined global `" ^ s ^ "'"
 243   | Linking_error (name, Unavailable_primitive s) ->
 244       "error while linking " ^ name ^ ".\n" ^
 245       "The external function `" ^ s ^ "' is not available"
 246   | Linking_error (name, Uninitialized_global s) ->
 247       "error while linking " ^ name ^ ".\n" ^
 248       "The module `" ^ s ^ "' is not yet initialized"
 249   | Corrupted_interface name ->
 250       "corrupted interface file " ^ name
 251   | File_not_found name ->
 252       "cannot find file " ^ name ^ " in search path"
 253   | Cannot_open_dll reason ->
 254       "error loading shared library: " ^ reason
 255   | Inconsistent_implementation name ->
 256       "implementation mismatch on " ^ name
 257
 258 let is_native = true
 259 let adapt_filename f = Filename.chop_extension f ^ ".cmxs"