Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* linkage-libdl.sml |
2 | * 2005 Matthew Fluet (mfluet@acm.org) | |
3 | * Adapted for MLton. | |
4 | *) | |
5 | ||
6 | (* linkage-dlopen.sml | |
7 | * | |
8 | * This module implements a high-level interface for dlopen. | |
9 | * While addresses (those obtained by applying function "addr" below | |
10 | * or addresses derived from those) will not remain valid across | |
11 | * export{ML,Fn}/restart, handles *will* stay valid. | |
12 | * | |
13 | * Copyright (c) 2004 by The Fellowship of SML/NJ | |
14 | * | |
15 | * Author: Matthias Blume (blume@tti-c.org) | |
16 | *) | |
17 | structure DynLinkage :> DYN_LINKAGE = struct | |
18 | ||
19 | exception DynLinkError of string | |
20 | val () = | |
21 | MLton.Exn.addExnMessager | |
22 | (fn DynLinkError s => SOME (concat ["DynLinkError: ", s]) | |
23 | | _ => NONE) | |
24 | ||
25 | local | |
26 | type era = unit ref | |
27 | type addr = MLton.Pointer.t | |
28 | ||
29 | (* a handle remembers an address and the era of its creation as | |
30 | * well as a function to re-create the address when necessary *) | |
31 | type h = (addr * era) ref * (unit -> addr) | |
32 | in | |
33 | type lib_handle = h | |
34 | type addr_handle = h | |
35 | end | |
36 | ||
37 | type mode = C_UInt.word | |
38 | local | |
39 | open RTLDFlags | |
40 | in | |
41 | fun mk_mode {lazy: bool, global: bool} : mode= | |
42 | C_UInt.orb | |
43 | (if lazy then RTLD_LAZY else RTLD_NOW, | |
44 | if global then RTLD_GLOBAL else RTLD_LOCAL) | |
45 | end | |
46 | ||
47 | local | |
48 | (* low-level linkage via dlopen/dlsym *) | |
49 | local | |
50 | val dlopen = | |
51 | _import "dlopen": string * mode -> MLton.Pointer.t; | |
52 | val dlopen_null = | |
53 | _import "dlopen": MLton.Pointer.t * mode -> MLton.Pointer.t; | |
54 | val dlsym = | |
55 | _import "dlsym": MLton.Pointer.t * string -> MLton.Pointer.t; | |
56 | val dlerror = | |
57 | _import "dlerror": unit -> MLton.Pointer.t; | |
58 | val dlclose = | |
59 | _import "dlclose": MLton.Pointer.t -> Int32.int; | |
60 | in | |
61 | (* mid-level linkage *) | |
62 | val dlopen = fn (filename, lazy, global) => | |
63 | let | |
64 | val mode = mk_mode {lazy = lazy, global = global} | |
65 | in | |
66 | case filename of | |
67 | NONE => dlopen_null (MLton.Pointer.null, mode) | |
68 | | SOME filename => dlopen (filename ^ "\000", mode) | |
69 | end | |
70 | val dlsym = fn (hndl, symbol) => | |
71 | dlsym (hndl, symbol ^ "\000") | |
72 | val dlerror = fn () => | |
73 | let | |
74 | val addr = dlerror () | |
75 | in | |
76 | if addr = MLton.Pointer.null | |
77 | then NONE | |
78 | else let | |
79 | fun loop (index, cs) = | |
80 | let | |
81 | val w = MLton.Pointer.getWord8 (addr, index) | |
82 | val c = Byte.byteToChar w | |
83 | in | |
84 | if c = #"\000" | |
85 | then SOME (implode (rev cs)) | |
86 | else loop (index + 1, c::cs) | |
87 | end | |
88 | in | |
89 | loop (0, []) | |
90 | end | |
91 | end | |
92 | val dlclose = fn hndl => | |
93 | let val _ = dlclose hndl | |
94 | in () | |
95 | end | |
96 | end | |
97 | ||
98 | (* label used for CleanUp *) | |
99 | (* | |
100 | val label = "DynLinkNewEra" | |
101 | *) | |
102 | (* generate a new "era" indicator *) | |
103 | fun newEra () = ref () | |
104 | ||
105 | (* the current era *) | |
106 | val now = ref (newEra ()) | |
107 | ||
108 | (* make a handle, remember era of creation of its current value *) | |
109 | fun mkHandle f = (ref (f (), !now), f) | |
110 | ||
111 | (* fetch from a handle; use the stored address if it was created | |
112 | * in the current era, otherwise regenerate the address *) | |
113 | fun get (r as ref (a, e), f) = | |
114 | if e = !now then a | |
115 | else let val a = f () | |
116 | in r := (a, !now); a | |
117 | end | |
118 | ||
119 | (* call a dl-function and check for errors *) | |
120 | fun checked dlf x = let | |
121 | val r = dlf x | |
122 | in | |
123 | case dlerror () of | |
124 | NONE => r | |
125 | | SOME s => raise DynLinkError s | |
126 | end | |
127 | ||
128 | (* add a cleanup handler that causes a new era to start | |
129 | * every time the runtime system is started anew *) | |
130 | (* | |
131 | open SMLofNJ.Internals.CleanUp | |
132 | val _ = addCleaner (label, [AtInit, AtInitFn], | |
133 | fn _ => now := newEra ()) | |
134 | ||
135 | val _ = Cleaner.addNew (Cleaner.atLoadWorld, fn () => now := newEra ()) | |
136 | *) | |
137 | in | |
138 | val main_lib = mkHandle (fn () => checked dlopen (NONE, true, true)) | |
139 | ||
140 | fun open_lib' { name, lazy, global, dependencies } = | |
141 | mkHandle (fn () => (app (ignore o get) dependencies; | |
142 | checked dlopen (SOME name, lazy, global))) | |
143 | fun open_lib { name, lazy, global } = | |
144 | open_lib' { name = name, lazy = lazy, global = global, | |
145 | dependencies = [] } | |
146 | ||
147 | fun lib_symbol (lh, s) = mkHandle (fn () => checked dlsym (get lh, s)) | |
148 | ||
149 | val addr = get | |
150 | ||
151 | fun close_lib lh = checked dlclose (get lh) | |
152 | end | |
153 | end |