l4/pkg/ocaml/ocaml/contrib/bytecomp/dll.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2001 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: dll.ml 9249 2009-05-01 01:46:50Z garrigue $ *)
  14
  15 (* Handling of dynamically-linked libraries *)
  16
  17 type dll_handle
  18 type dll_address
  19 type dll_mode = For_checking | For_execution
  20
  21 external dll_open: dll_mode -> string -> dll_handle = "caml_dynlink_open_lib"
  22 external dll_close: dll_handle -> unit = "caml_dynlink_close_lib"
  23 external dll_sym: dll_handle -> string -> dll_address
  24                 = "caml_dynlink_lookup_symbol"
  25          (* returned dll_address may be Val_unit *)
  26 external add_primitive: dll_address -> int = "caml_dynlink_add_primitive"
  27 external get_current_dlls: unit -> dll_handle array
  28                                            = "caml_dynlink_get_current_libs"
  29
  30 (* Current search path for DLLs *)
  31 let search_path = ref ([] : string list)
  32
  33 (* DLLs currently opened *)
  34 let opened_dlls = ref ([] : dll_handle list)
  35
  36 (* File names for those DLLs *)
  37 let names_of_opened_dlls = ref ([] : string list)
  38
  39 (* Add the given directories to the search path for DLLs. *)
  40 let add_path dirs =
  41   search_path := dirs @ !search_path
  42
  43 (* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *)
  44
  45 let extract_dll_name file =
  46   if Filename.check_suffix file Config.ext_dll then
  47     Filename.chop_suffix file Config.ext_dll
  48   else if String.length file >= 2 && String.sub file 0 2 = "-l" then
  49     "dll" ^ String.sub file 2 (String.length file - 2)
  50   else
  51     file (* will cause error later *)
  52
  53 (* Open a list of DLLs, adding them to opened_dlls.
  54    Raise [Failure msg] in case of error. *)
  55
  56 let open_dll mode name =
  57   let name = name ^ Config.ext_dll in
  58   let fullname =
  59     try
  60       let fullname = Misc.find_in_path !search_path name in
  61       if Filename.is_implicit fullname then
  62         Filename.concat Filename.current_dir_name fullname
  63       else fullname
  64     with Not_found -> name in
  65   if not (List.mem fullname !names_of_opened_dlls) then begin
  66     try
  67       let dll = dll_open mode fullname in
  68       names_of_opened_dlls := fullname :: !names_of_opened_dlls;
  69       opened_dlls := dll :: !opened_dlls
  70     with Failure msg ->
  71       failwith (fullname ^ ": " ^ msg)
  72   end
  73
  74 let open_dlls mode names =
  75   List.iter (open_dll mode) names
  76
  77 (* Close all DLLs *)
  78
  79 let close_all_dlls () =
  80   List.iter dll_close !opened_dlls;
  81   opened_dlls := [];
  82   names_of_opened_dlls := []
  83
  84 (* Find a primitive in the currently opened DLLs.
  85    Raise [Not_found] if not found. *)
  86
  87 let find_primitive prim_name =
  88   let rec find seen = function
  89     [] ->
  90       raise Not_found
  91   | dll :: rem ->
  92       let addr = dll_sym dll prim_name in
  93       if addr == Obj.magic () then find (dll :: seen) rem else begin
  94         if seen <> [] then opened_dlls := dll :: List.rev_append seen rem;
  95         addr
  96       end in
  97   find [] !opened_dlls
  98
  99 (* If linking in core (dynlink or toplevel), synchronize the VM
 100    table of primitive with the linker's table of primitive
 101    by storing the given primitive function at the given position
 102    in the VM table of primitives.  *)
 103
 104 let linking_in_core = ref false
 105
 106 let synchronize_primitive num symb =
 107   if !linking_in_core then begin
 108     let actual_num = add_primitive symb in
 109     assert (actual_num = num)
 110   end
 111
 112 (* Read the [ld.conf] file and return the corresponding list of directories *)
 113
 114 let ld_conf_contents () =
 115   let path = ref [] in
 116   begin try
 117     let ic = open_in (Filename.concat Config.standard_library "ld.conf") in
 118     begin try
 119       while true do
 120         path := input_line ic :: !path
 121       done
 122     with End_of_file -> ()
 123     end;
 124     close_in ic
 125   with Sys_error _ -> ()
 126   end;
 127   List.rev !path
 128
 129 (* Split the CAML_LD_LIBRARY_PATH environment variable and return
 130    the corresponding list of directories.  *)
 131
 132 let split str sep =
 133   let rec split_rec pos =
 134     if pos >= String.length str then [] else begin
 135       try
 136         let newpos = String.index_from str pos sep in
 137         String.sub str pos (newpos - pos) ::
 138         split_rec (newpos + 1)
 139       with Not_found ->
 140         [String.sub str pos (String.length str - pos)]
 141     end in
 142   split_rec 0
 143
 144 let ld_library_path_contents () =
 145   let path_separator =
 146     match Sys.os_type with
 147     | "Unix" | "Cygwin" -> ':'
 148     | "Win32" -> ';'
 149     | _ -> assert false in
 150   try
 151     split (Sys.getenv "CAML_LD_LIBRARY_PATH") path_separator
 152   with Not_found ->
 153     []
 154
 155 let split_dll_path path =
 156   split path '\000'
 157
 158 (* Initialization for separate compilation *)
 159
 160 let init_compile nostdlib =
 161   search_path :=
 162     ld_library_path_contents() @
 163     (if nostdlib then [] else ld_conf_contents())
 164
 165 (* Initialization for linking in core (dynlink or toplevel) *)
 166
 167 let init_toplevel dllpath =
 168   search_path :=
 169     ld_library_path_contents() @
 170     split_dll_path dllpath @
 171     ld_conf_contents();
 172   opened_dlls := Array.to_list (get_current_dlls());
 173   names_of_opened_dlls := [];
 174   linking_in_core := true
 175