Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/ml-nlffi-lib/memory/linkage-dlopen.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-nlffi-lib/memory/linkage-dlopen.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1015 - (view) (download)

1 : blume 840 (*
2 :     * This module implements a high-level interface for dlopen.
3 :     * While addresses (those obtained by applying function "addr" below
4 :     * or addresses derived from those) will not remain valid across
5 :     * export{ML,Fn}/restart, handles *will* stay valid.
6 :     *
7 :     * (C) 2001, Lucent Technologies, Bell Laboratories
8 :     *
9 :     * author: Matthias Blume
10 :     *)
11 :     structure DynLinkage :> DYN_LINKAGE = struct
12 :    
13 :     exception DynLinkError of string
14 :    
15 :     local
16 :     type era = unit ref
17 :     type addr = Word32.word
18 :    
19 :     (* a handle remembers an address and the era of its creation as
20 :     * well as a function to re-create the address when necessary *)
21 :     type h = (addr * era) ref * (unit -> addr)
22 :     in
23 :     type lib_handle = h
24 :     type addr_handle = h
25 :     end
26 :    
27 :     local
28 :     structure CI = Unsafe.CInterface
29 :    
30 :     (* low-level linkage via dlopen/dlsym *)
31 :     val dlopen : string option * bool * bool -> Word32.word =
32 :     CI.c_function "UNIX-Dynload" "dlopen"
33 :     val dlsym : Word32.word * string -> Word32.word =
34 :     CI.c_function "UNIX-Dynload" "dlsym"
35 :     val dlerror : unit -> string option =
36 :     CI.c_function "UNIX-Dynload" "dlerror"
37 :     val dlclose : Word32.word -> unit =
38 :     CI.c_function "UNIX-Dynload" "dlclose"
39 :    
40 :     (* label used for CleanUp *)
41 :     val label = "DynLinkNewEra"
42 :    
43 :     (* generate a new "era" indicator *)
44 :     fun newEra () = ref ()
45 :    
46 :     (* the current era *)
47 :     val now = ref (newEra ())
48 :    
49 :     (* make a handle, remember era of creation of its current value *)
50 :     fun mkHandle f = (ref (f (), !now), f)
51 :    
52 :     (* fetch from a handle; use the stored address if it was created
53 :     * in the current era, otherwise regenerate the address *)
54 :     fun get (r as ref (a, e), f) =
55 :     if e = !now then a
56 :     else let val a = f ()
57 :     in r := (a, !now); a
58 :     end
59 :    
60 :     (* call a dl-function and check for errors *)
61 :     fun checked dlf x = let
62 :     val r = dlf x
63 :     in
64 :     case dlerror () of
65 :     NONE => r
66 :     | SOME s => raise DynLinkError s
67 :     end
68 :    
69 :     (* add a cleanup handler that causes a new era to start
70 :     * every time the runtime system is started anew *)
71 :     open SMLofNJ.Internals.CleanUp
72 :     val _ = addCleaner (label, [AtInit, AtInitFn],
73 :     fn _ => now := newEra ())
74 :     in
75 :     val main_lib = mkHandle (fn () => checked dlopen (NONE, true, true))
76 :    
77 : blume 1015 fun open_lib' { name, lazy, global, dependencies } =
78 :     mkHandle (fn () => (app (ignore o get) dependencies;
79 :     checked dlopen (SOME name, lazy, global)))
80 : blume 840 fun open_lib { name, lazy, global } =
81 : blume 1015 open_lib' { name = name, lazy = lazy, global = global,
82 :     dependencies = [] }
83 : blume 840
84 : blume 1011 fun lib_symbol (lh, s) = mkHandle (fn () => checked dlsym (get lh, s))
85 : blume 840
86 :     val addr = get
87 :    
88 :     fun close_lib lh = dlclose (get lh)
89 :     end
90 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0