1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2009 Clozure Associates |
---|
4 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
5 | ;;; This file is part of Clozure CL. |
---|
6 | ;;; |
---|
7 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
8 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
9 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
10 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
11 | ;;; conflict, the preamble takes precedence. |
---|
12 | ;;; |
---|
13 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
14 | ;;; |
---|
15 | ;;; The LLGPL is also available online at |
---|
16 | ;;; http://opensource.franz.com/preamble.html |
---|
17 | |
---|
18 | |
---|
19 | ; l0-cfm-support.lisp |
---|
20 | |
---|
21 | (in-package "CCL") |
---|
22 | |
---|
23 | #+windows-target |
---|
24 | (progn |
---|
25 | (defvar *windows-invalid-handle* nil) |
---|
26 | (setq *windows-invalid-handle* (%int-to-ptr #+64-bit-target #xffffffffffffffff #+32-bit-target #xffffffff))) |
---|
27 | |
---|
28 | |
---|
29 | ;;; We have several different conventions for representing an |
---|
30 | ;;; "entry" (a foreign symbol address, possibly represented as |
---|
31 | ;;; something cheaper than a MACPTR.) Destructively modify |
---|
32 | ;;; ADDR so that it points to where ENTRY points. |
---|
33 | (defun entry->addr (entry addr) |
---|
34 | #+ppc32-target |
---|
35 | ;; On PPC32, all function addresses have their low 2 bits clear; |
---|
36 | ;; so do fixnums. |
---|
37 | (%setf-macptr-to-object addr entry) |
---|
38 | #+ppc64-target |
---|
39 | ;; On PPC64, some addresses can use the fixnum trick. In other |
---|
40 | ;; cases, an "entry" is just a MACPTR. |
---|
41 | (if (typep entry 'fixnum) |
---|
42 | (%setf-macptr-to-object addr entry) |
---|
43 | (%setf-macptr addr entry)) |
---|
44 | ;; On x86, an "entry" is just an integer. There might elswehere be |
---|
45 | ;; some advantage in treating those integers as signed (they might |
---|
46 | ;; be more likely to be fixnums, for instance), so ensure that they |
---|
47 | ;; aren't. |
---|
48 | #+(or x86-target arm-target) |
---|
49 | (%setf-macptr addr (%int-to-ptr |
---|
50 | (if (< entry 0) |
---|
51 | (logand entry (1- (ash 1 target::nbits-in-word))) |
---|
52 | entry))) |
---|
53 | #-(or ppc-target x86-target arm-target) (dbg "Fix entry->addr")) |
---|
54 | |
---|
55 | |
---|
56 | |
---|
57 | |
---|
58 | ;;; Bootstrapping. Real version is in l1-aprims. |
---|
59 | ;;; Called by expansion of with-pstrs |
---|
60 | |
---|
61 | (defun byte-length (string &optional script start end) |
---|
62 | (declare (ignore script)) |
---|
63 | (when (or start end) |
---|
64 | (error "Don't support start or end args yet")) |
---|
65 | (if (base-string-p string) |
---|
66 | (length string) |
---|
67 | (error "Don't support non base-string yet."))) |
---|
68 | |
---|
69 | |
---|
70 | |
---|
71 | |
---|
72 | (defun external-entry-point-p (x) |
---|
73 | (istruct-typep x 'external-entry-point)) |
---|
74 | |
---|
75 | ;;; On both Linux and FreeBSD, RTLD_NEXT and RTLD_DEFAULT behave |
---|
76 | ;;; the same way wrt symbols defined somewhere other than the lisp |
---|
77 | ;;; kernel. On Solaris, RTLD_DEFAULT will return the address of |
---|
78 | ;;; an imported symbol's procedure linkage table entry if the symbol |
---|
79 | ;;; has a plt entry (e.g., if it happens to be referenced by the |
---|
80 | ;;; lisp kernel.) *RTLD-NEXT* is therefore a slightly better |
---|
81 | ;;; default; we've traditionaly used *RTLD-DEFAULT*. |
---|
82 | (defvar *rtld-next*) |
---|
83 | (defvar *rtld-default*) |
---|
84 | (defvar *rtld-use*) |
---|
85 | (setq *rtld-next* (%incf-ptr (%null-ptr) -1) |
---|
86 | *rtld-default* (%int-to-ptr #+(or linux-target darwin-target windows-target) 0 |
---|
87 | #-(or linux-target darwin-target windows-target) -2) |
---|
88 | *rtld-use* #+solaris-target *rtld-next* #-solaris-target *rtld-default*) |
---|
89 | |
---|
90 | #+(or linux-target freebsd-target solaris-target) |
---|
91 | (progn |
---|
92 | |
---|
93 | (defvar *dladdr-entry*) |
---|
94 | |
---|
95 | ;;; I can't think of a reason to change this. |
---|
96 | (defvar *dlopen-flags* nil) |
---|
97 | (setq *dlopen-flags* (logior #$RTLD_GLOBAL #$RTLD_NOW)) |
---|
98 | ) |
---|
99 | |
---|
100 | (defvar *eeps* nil) |
---|
101 | |
---|
102 | (defvar *fvs* nil) |
---|
103 | |
---|
104 | (defun eeps () |
---|
105 | (or *eeps* |
---|
106 | (setq *eeps* (make-hash-table :test #'equal)))) |
---|
107 | |
---|
108 | (defun fvs () |
---|
109 | (or *fvs* |
---|
110 | (setq *fvs* (make-hash-table :test #'equal)))) |
---|
111 | |
---|
112 | (defun unload-foreign-variables (lib) |
---|
113 | (let* ((fvs (fvs))) |
---|
114 | (when fvs |
---|
115 | (maphash #'(lambda (k fv) |
---|
116 | (declare (ignore k)) |
---|
117 | (when (fv.addr fv) |
---|
118 | (when (or (null lib) (eq (fv.container fv) lib)) |
---|
119 | (setf (fv.addr fv) nil)))) |
---|
120 | fvs)))) |
---|
121 | |
---|
122 | ;;; Walk over all registered entrypoints, invalidating any whose container |
---|
123 | ;;; is the specified library. Return true if any such entrypoints were |
---|
124 | ;;; found. |
---|
125 | (defun unload-library-entrypoints (lib) |
---|
126 | (let* ((count 0)) |
---|
127 | (declare (fixnum count)) |
---|
128 | (maphash #'(lambda (k eep) |
---|
129 | (declare (ignore k)) |
---|
130 | (when (eep.address eep) |
---|
131 | (when (or (null lib) (eq (eep.container eep) lib)) |
---|
132 | (setf (eep.address eep) nil) |
---|
133 | (incf count)))) |
---|
134 | (eeps)) |
---|
135 | (not (zerop count)))) |
---|
136 | |
---|
137 | (defun shared-library-with-name (name) |
---|
138 | (let* ((namelen (length name))) |
---|
139 | (dolist (lib *shared-libraries*) |
---|
140 | (let* ((libname (shlib.soname lib))) |
---|
141 | (when (%simple-string= name libname 0 0 namelen (length libname)) |
---|
142 | (return lib)))))) |
---|
143 | |
---|
144 | (defun generate-external-functions (path) |
---|
145 | (let* ((names ())) |
---|
146 | (maphash #'(lambda (k ignore) |
---|
147 | (declare (ignore ignore)) |
---|
148 | (push k names)) (eeps)) |
---|
149 | (with-open-file (stream path |
---|
150 | :direction :output |
---|
151 | :if-exists :supersede |
---|
152 | :if-does-not-exist :create) |
---|
153 | (dolist (k names) (format stream "~&extern void * ~a();" k)) |
---|
154 | |
---|
155 | (format stream "~&external_function external_functions[] = {") |
---|
156 | (dolist (k names) (format stream "~&~t{~s,~a}," k k)) |
---|
157 | (format stream "~&~t{0,0}~&};")))) |
---|
158 | |
---|
159 | |
---|
160 | (defvar *shared-libraries* nil) |
---|
161 | |
---|
162 | #+(or linux-target freebsd-target solaris-target) |
---|
163 | (progn |
---|
164 | |
---|
165 | ;; (pref ptr :link_map.l_addr) is an integer on Linux and a Pointer on FreeBSD |
---|
166 | ;; This macro returns a pointer on all platforms |
---|
167 | (defmacro link_map.l_addr (ptr) |
---|
168 | (let* ((record (%find-foreign-record :link_map)) |
---|
169 | (field (%find-foreign-record-type-field record :l_addr)) |
---|
170 | (offset (/ (foreign-record-field-offset field) 8))) |
---|
171 | `(%get-ptr ,ptr ,offset))) |
---|
172 | |
---|
173 | (defun soname-ptr-from-link-map (map) |
---|
174 | (let* ((path (pref map :link_map.l_name))) |
---|
175 | (if (%null-ptr-p path) |
---|
176 | (let* ((p (malloc 1))) |
---|
177 | (setf (%get-unsigned-byte p 0) 0) |
---|
178 | p) |
---|
179 | (if (eql (%get-unsigned-byte path 0) 0) |
---|
180 | path |
---|
181 | (with-macptrs ((dyn-strings) |
---|
182 | (dynamic-entries (pref map :link_map.l_ld))) |
---|
183 | (if (%null-ptr-p dynamic-entries) |
---|
184 | (%null-ptr) |
---|
185 | (let* ((soname-offset nil)) |
---|
186 | ;; Walk over the entries in the file's dynamic segment; the |
---|
187 | ;; last such entry will have a tag of #$DT_NULL. Note the |
---|
188 | ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD) |
---|
189 | ;; address of the dynamic string table and the offset of the |
---|
190 | ;; #$DT_SONAME string in that string table. |
---|
191 | ;; Actually, the above isn't quite right; there seem to |
---|
192 | ;; be cases (involving vDSO) where the address of a library's |
---|
193 | ;; dynamic string table is expressed as an offset relative |
---|
194 | ;; to link_map.l_addr as well. |
---|
195 | (loop |
---|
196 | (case #+32-bit-target (pref dynamic-entries :<E>lf32_<D>yn.d_tag) |
---|
197 | #+64-bit-target (pref dynamic-entries :<E>lf64_<D>yn.d_tag) |
---|
198 | (#. #$DT_NULL (return)) |
---|
199 | (#. #$DT_SONAME |
---|
200 | (setq soname-offset |
---|
201 | #+32-bit-target (pref dynamic-entries |
---|
202 | :<E>lf32_<D>yn.d_un.d_val) |
---|
203 | #+64-bit-target (pref dynamic-entries |
---|
204 | :<E>lf64_<D>yn.d_un.d_val))) |
---|
205 | (#. #$DT_STRTAB |
---|
206 | (%setf-macptr dyn-strings |
---|
207 | ;; Try to guess whether we're dealing |
---|
208 | ;; with a displacement or with an |
---|
209 | ;; absolute address. There may be |
---|
210 | ;; a better way to determine this, |
---|
211 | ;; but for now we assume that absolute |
---|
212 | ;; addresses aren't negative and that |
---|
213 | ;; displacements are. |
---|
214 | (let* ((disp (%get-signed-natural |
---|
215 | dynamic-entries |
---|
216 | target::node-size))) |
---|
217 | #+(or freebsd-target solaris-target android-target) |
---|
218 | (%inc-ptr (pref map :link_map.l_addr) disp) |
---|
219 | #-(or freebsd-target solaris-target android-target) |
---|
220 | (let* ((udisp #+32-bit-target (pref dynamic-entries |
---|
221 | :<E>lf32_<D>yn.d_un.d_val) |
---|
222 | #+64-bit-target (pref dynamic-entries |
---|
223 | :<E>lf64_<D>yn.d_un.d_val))) |
---|
224 | (if (and (> udisp (pref map :link_map.l_addr)) |
---|
225 | (< udisp (%ptr-to-int dynamic-entries))) |
---|
226 | (%int-to-ptr udisp) |
---|
227 | (%int-to-ptr |
---|
228 | (if (< disp 0) |
---|
229 | (+ disp (pref map :link_map.l_addr)) |
---|
230 | disp)))))))) |
---|
231 | (%setf-macptr dynamic-entries |
---|
232 | (%inc-ptr dynamic-entries |
---|
233 | #+32-bit-target |
---|
234 | (record-length :<E>lf32_<D>yn) |
---|
235 | #+64-bit-target |
---|
236 | (record-length :<E>lf64_<D>yn)))) |
---|
237 | (if (and soname-offset |
---|
238 | (not (%null-ptr-p dyn-strings))) |
---|
239 | (%inc-ptr dyn-strings soname-offset) |
---|
240 | ;; Use the full pathname of the library. |
---|
241 | (pref map :link_map.l_name))))))))) |
---|
242 | |
---|
243 | (defun shared-library-at (base) |
---|
244 | (dolist (lib *shared-libraries*) |
---|
245 | (when (eql (shlib.base lib) base) |
---|
246 | (return lib)))) |
---|
247 | |
---|
248 | |
---|
249 | |
---|
250 | (defun shlib-from-map-entry (m) |
---|
251 | (let* ((base (link_map.l_addr m))) |
---|
252 | ;; On relatively modern Linux systems, this is often NULL. |
---|
253 | ;; I'm not sure what (SELinux ? Pre-binding ? Something else ?) |
---|
254 | ;; counts as being "relatively modern" in this case. |
---|
255 | ;; The link-map's l_ld field is a pointer to the .so's dynamic |
---|
256 | ;; section, and #_dladdr seems to recognize that as being an |
---|
257 | ;; address within the library and returns a reasonable "base address". |
---|
258 | (when (%null-ptr-p base) |
---|
259 | (let* ((addr (%library-base-containing-address (pref m :link_map.l_ld)))) |
---|
260 | (if addr (setq base addr)))) |
---|
261 | (unless (%null-ptr-p base) |
---|
262 | (or (let* ((existing-lib (shared-library-at base))) |
---|
263 | (when (and existing-lib (null (shlib.map existing-lib))) |
---|
264 | (setf (shlib.map existing-lib) m |
---|
265 | (shlib.pathname existing-lib) |
---|
266 | (%get-cstring (pref m :link_map.l_name)) |
---|
267 | (shlib.base existing-lib) base)) |
---|
268 | existing-lib) |
---|
269 | (let* ((soname-ptr (soname-ptr-from-link-map m)) |
---|
270 | (soname (unless (%null-ptr-p soname-ptr) (%get-cstring soname-ptr))) |
---|
271 | (pathname (%get-cstring (pref m :link_map.l_name))) |
---|
272 | (shlib (shared-library-with-name soname))) |
---|
273 | (if shlib |
---|
274 | (setf (shlib.map shlib) m |
---|
275 | (shlib.base shlib) base |
---|
276 | (shlib.pathname shlib) pathname) |
---|
277 | (push (setq shlib (%cons-shlib soname pathname m base)) |
---|
278 | *shared-libraries*)) |
---|
279 | shlib))))) |
---|
280 | |
---|
281 | |
---|
282 | (defun %get-r-debug () |
---|
283 | (let* ((addr (ff-call (%kernel-import target::kernel-import-get-r-debug) |
---|
284 | address))) |
---|
285 | (unless (%null-ptr-p addr) |
---|
286 | addr))) |
---|
287 | |
---|
288 | (defun %link-map-address () |
---|
289 | (let* ((r_debug (%get-r-debug))) |
---|
290 | (if r_debug |
---|
291 | (pref r_debug :r_debug.r_map) |
---|
292 | (let* ((p (or (foreign-symbol-address "_dl_loaded") |
---|
293 | (foreign-symbol-address "_rtld_global")))) |
---|
294 | (if p |
---|
295 | (%get-ptr p)))))) |
---|
296 | |
---|
297 | (defun %walk-shared-libraries (f) |
---|
298 | (let* ((loaded (%link-map-address))) |
---|
299 | (do* ((map (pref loaded :link_map.l_next) (pref map :link_map.l_next))) |
---|
300 | ((%null-ptr-p map)) |
---|
301 | (funcall f map)))) |
---|
302 | |
---|
303 | |
---|
304 | (defun %dlopen-shlib (l) |
---|
305 | (with-cstrs ((n (shlib.soname l))) |
---|
306 | (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) |
---|
307 | :address n |
---|
308 | :unsigned-fullword *dlopen-flags* |
---|
309 | :void))) |
---|
310 | |
---|
311 | (defun init-shared-libraries () |
---|
312 | (setq *dladdr-entry* (foreign-symbol-entry "dladdr")) |
---|
313 | (when (null *shared-libraries*) |
---|
314 | (%walk-shared-libraries #'shlib-from-map-entry) |
---|
315 | ;;; On Linux, it seems to be necessary to open each of these |
---|
316 | ;;; libraries yet again, specifying the RTLD_GLOBAL flag. |
---|
317 | ;;; On FreeBSD, it seems desirable -not- to do that. |
---|
318 | #+linux-target |
---|
319 | (dolist (l *shared-libraries*) |
---|
320 | (%dlopen-shlib l)))) |
---|
321 | |
---|
322 | (init-shared-libraries) |
---|
323 | |
---|
324 | |
---|
325 | |
---|
326 | |
---|
327 | |
---|
328 | |
---|
329 | |
---|
330 | (defun open-shared-library-internal (name) |
---|
331 | (let* ((handle (with-cstrs ((name name)) |
---|
332 | (ff-call |
---|
333 | (%kernel-import target::kernel-import-GetSharedLibrary) |
---|
334 | :address name |
---|
335 | :unsigned-fullword *dlopen-flags* |
---|
336 | :address))) |
---|
337 | (link-map #+(and linux-target (not android-target)) handle |
---|
338 | #+(or freebsd-target solaris-target) |
---|
339 | (if (%null-ptr-p handle) |
---|
340 | handle |
---|
341 | (rlet ((p :address)) |
---|
342 | (if (eql 0 (ff-call |
---|
343 | (foreign-symbol-entry "dlinfo") |
---|
344 | :address handle |
---|
345 | :int #$RTLD_DI_LINKMAP |
---|
346 | :address p |
---|
347 | :int)) |
---|
348 | (pref p :address) |
---|
349 | (%null-ptr)))) |
---|
350 | #+android-target (if (%null-ptr-p handle) |
---|
351 | handle |
---|
352 | (pref handle :soinfo.linkmap)))) |
---|
353 | (if (%null-ptr-p link-map) |
---|
354 | (values nil (dlerror)) |
---|
355 | (prog1 (let* ((lib (shlib-from-map-entry link-map))) |
---|
356 | (incf (shlib.opencount lib)) |
---|
357 | (setf (shlib.handle lib) handle) |
---|
358 | lib) |
---|
359 | (%walk-shared-libraries |
---|
360 | #'(lambda (map) |
---|
361 | (let* ((addr (link_map.l_addr map))) |
---|
362 | (unless (or (%null-ptr-p addr) |
---|
363 | (shared-library-at addr)) |
---|
364 | (let* ((new (shlib-from-map-entry map))) |
---|
365 | (%dlopen-shlib new)))))))))) |
---|
366 | |
---|
367 | ) |
---|
368 | |
---|
369 | |
---|
370 | #+darwin-target |
---|
371 | (progn |
---|
372 | |
---|
373 | (defun shared-library-with-handle (handle) |
---|
374 | (dolist (lib *shared-libraries*) |
---|
375 | (when (eql (shlib.handle lib) handle) |
---|
376 | (return lib)))) |
---|
377 | |
---|
378 | |
---|
379 | |
---|
380 | |
---|
381 | |
---|
382 | |
---|
383 | |
---|
384 | |
---|
385 | |
---|
386 | ;;; end darwin-target |
---|
387 | ) |
---|
388 | |
---|
389 | #+windows-target |
---|
390 | (progn |
---|
391 | (defvar *current-process-handle*) |
---|
392 | (defvar *enum-process-modules-addr*) |
---|
393 | (defvar *get-module-file-name-addr*) |
---|
394 | (defvar *get-module-base-name-addr*) |
---|
395 | (defvar *get-module-handle-ex-addr*) |
---|
396 | |
---|
397 | (defun nbackslash-to-forward-slash (namestring) |
---|
398 | (dotimes (i (length namestring) namestring) |
---|
399 | (when (eql (schar namestring i) #\\) |
---|
400 | (setf (schar namestring i) #\/)))) |
---|
401 | |
---|
402 | (defun init-windows-ffi () |
---|
403 | (%revive-macptr *windows-invalid-handle*) |
---|
404 | (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address)) |
---|
405 | (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules")) |
---|
406 | (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA")) |
---|
407 | (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA")) |
---|
408 | (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA"))) |
---|
409 | |
---|
410 | (init-windows-ffi) |
---|
411 | |
---|
412 | (defun hmodule-pathname (hmodule) |
---|
413 | (do* ((bufsize 128)) |
---|
414 | () |
---|
415 | (%stack-block ((name bufsize)) |
---|
416 | (let* ((needed (ff-call *get-module-file-name-addr* |
---|
417 | :address hmodule |
---|
418 | :address name |
---|
419 | :signed-fullword bufsize |
---|
420 | :signed-fullword))) |
---|
421 | (if (eql 0 needed) |
---|
422 | (return nil) |
---|
423 | (if (<= bufsize needed) |
---|
424 | (setq bufsize (+ bufsize bufsize)) |
---|
425 | (return (nbackslash-to-forward-slash (%str-from-ptr name needed))))))))) |
---|
426 | |
---|
427 | (defun hmodule-basename (hmodule) |
---|
428 | (do* ((bufsize 64)) |
---|
429 | () |
---|
430 | (%stack-block ((name bufsize)) |
---|
431 | (let* ((needed (ff-call *get-module-base-name-addr* |
---|
432 | :address *current-process-handle* |
---|
433 | :address hmodule |
---|
434 | :address name |
---|
435 | :signed-fullword bufsize |
---|
436 | :signed-fullword))) |
---|
437 | (if (eql 0 needed) |
---|
438 | (return nil) |
---|
439 | (if (< bufsize needed) |
---|
440 | (setq bufsize needed) |
---|
441 | (return (%str-from-ptr name needed)))))))) |
---|
442 | |
---|
443 | (defun existing-shlib-for-hmodule (hmodule) |
---|
444 | (dolist (shlib *shared-libraries*) |
---|
445 | (when (eql hmodule (shlib.map shlib)) (return shlib)))) |
---|
446 | |
---|
447 | |
---|
448 | (defun shared-library-from-hmodule (hmodule) |
---|
449 | (or (existing-shlib-for-hmodule hmodule) |
---|
450 | (let* ((shlib (%cons-shlib (hmodule-basename hmodule) |
---|
451 | (hmodule-pathname hmodule) |
---|
452 | hmodule |
---|
453 | hmodule))) |
---|
454 | (push shlib *shared-libraries*) |
---|
455 | shlib))) |
---|
456 | |
---|
457 | (defun for-each-loaded-module (f) |
---|
458 | (let* ((have (* 16 (record-length #>HMODULE)))) |
---|
459 | (rlet ((pneed #>DWORD)) |
---|
460 | (loop |
---|
461 | (%stack-block ((modules have)) |
---|
462 | (ff-call *enum-process-modules-addr* |
---|
463 | :address *current-process-handle* |
---|
464 | :address modules |
---|
465 | #>DWORD have |
---|
466 | :address pneed) |
---|
467 | (let* ((need (pref pneed #>DWORD))) |
---|
468 | (if (> need have) |
---|
469 | (setq have need) |
---|
470 | (return |
---|
471 | (do* ((i 0 (+ i (record-length #>HMODULE)))) |
---|
472 | ((= i need)) |
---|
473 | (funcall f (%get-ptr modules i))))))))))) |
---|
474 | |
---|
475 | (defun init-shared-libraries () |
---|
476 | (for-each-loaded-module #'shared-library-from-hmodule)) |
---|
477 | |
---|
478 | (defun shlib-containing-entry (addr &optional name) |
---|
479 | (with-macptrs ((p (%int-to-ptr addr))) |
---|
480 | (shlib-containing-address p name))) |
---|
481 | |
---|
482 | (defun shlib-containing-address (addr &optional name) |
---|
483 | (declare (ignore name)) |
---|
484 | (rlet ((phmodule :address (%null-ptr))) |
---|
485 | (let* ((found (ff-call *get-module-handle-ex-addr* |
---|
486 | #>DWORD (logior |
---|
487 | #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS |
---|
488 | #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT) |
---|
489 | :address addr |
---|
490 | :address phmodule |
---|
491 | #>BOOL))) |
---|
492 | (unless (eql 0 found) |
---|
493 | (let* ((hmodule (pref phmodule :address))) |
---|
494 | (dolist (lib *shared-libraries*) |
---|
495 | (when (eql (shlib.map lib) hmodule) |
---|
496 | (return lib)))))))) |
---|
497 | |
---|
498 | |
---|
499 | (defun open-shared-library-internal (name) |
---|
500 | (let* ((hmodule (with-cstrs ((name name)) |
---|
501 | (ff-call |
---|
502 | (%kernel-import target::kernel-import-GetSharedLibrary) |
---|
503 | :address name |
---|
504 | :unsigned-fullword 0 |
---|
505 | :address))) |
---|
506 | (shlib (unless (%null-ptr-p hmodule) |
---|
507 | (shared-library-from-hmodule hmodule)))) |
---|
508 | (if shlib |
---|
509 | (progn |
---|
510 | (incf (shlib.opencount shlib)) |
---|
511 | (setf (shlib.handle shlib) hmodule) |
---|
512 | shlib) |
---|
513 | (values nil (%windows-error-string (get-last-windows-error)))))) |
---|
514 | |
---|
515 | (init-shared-libraries) |
---|
516 | |
---|
517 | (defun revive-shared-libraries () |
---|
518 | (dolist (lib *shared-libraries*) |
---|
519 | (setf (shlib.map lib) nil |
---|
520 | (shlib.handle lib) nil |
---|
521 | (shlib.pathname lib) nil |
---|
522 | (shlib.base lib) nil) |
---|
523 | (let* ((soname (shlib.soname lib)) |
---|
524 | (soname-len (length soname))) |
---|
525 | (block found |
---|
526 | (for-each-loaded-module |
---|
527 | (lambda (m) |
---|
528 | (let* ((module-soname (hmodule-basename m))) |
---|
529 | (when (%simple-string= soname module-soname 0 0 soname-len (length module-soname)) |
---|
530 | (let* ((m (%inc-ptr m 0))) |
---|
531 | (setf (shlib.base lib) m |
---|
532 | (shlib.map lib) m |
---|
533 | (shlib.pathname lib) (hmodule-pathname m))) |
---|
534 | (return-from found))))))))) |
---|
535 | |
---|
536 | (defun reopen-user-libraries () |
---|
537 | (dolist (lib *shared-libraries*) |
---|
538 | (unless (shlib.map lib) |
---|
539 | (let* ((handle (with-cstrs ((name (shlib.soname lib))) |
---|
540 | (ff-call |
---|
541 | (%kernel-import target::kernel-import-GetSharedLibrary) |
---|
542 | :address name |
---|
543 | :unsigned-fullword 0 |
---|
544 | :address)))) |
---|
545 | (unless (%null-ptr-p handle) |
---|
546 | (setf (shlib.handle lib) handle |
---|
547 | (shlib.base lib) handle |
---|
548 | (shlib.map lib) handle |
---|
549 | (shlib.pathname lib) (hmodule-pathname handle) |
---|
550 | (shlib.opencount lib) 1)))))) |
---|
551 | |
---|
552 | |
---|
553 | |
---|
554 | ;;; end windows-target |
---|
555 | ) |
---|
556 | |
---|
557 | |
---|
558 | (defun ensure-open-shlib (c force) |
---|
559 | (if (or (shlib.map c) (not force)) |
---|
560 | *rtld-use* |
---|
561 | (error "Shared library not open: ~s" (shlib.soname c)))) |
---|
562 | |
---|
563 | (defun resolve-container (c force) |
---|
564 | (if c |
---|
565 | (ensure-open-shlib c force) |
---|
566 | *rtld-use* |
---|
567 | )) |
---|
568 | |
---|
569 | |
---|
570 | |
---|
571 | |
---|
572 | ;;; An "entry" can be fixnum (the low 2 bits are clear) which represents |
---|
573 | ;;; a (32-bit word)-aligned address. That convention covers all |
---|
574 | ;;; function addresses on ppc32 and works for addresses that are |
---|
575 | ;;; 0 mod 8 on PPC64, but can't work for things that're byte-aligned |
---|
576 | ;;; (x8664 and other non-RISC platforms.) |
---|
577 | ;;; For PPC64, we may have to cons up a macptr if people use broken |
---|
578 | ;;; linkers. (There are usually cache advantages to aligning ppc |
---|
579 | ;;; function addresses on at least a 16-byte boundary, but some |
---|
580 | ;;; linkers don't quite get the concept ...) |
---|
581 | |
---|
582 | (defun foreign-symbol-entry (name &optional (handle *rtld-use*)) |
---|
583 | "Try to resolve the address of the foreign symbol name. If successful, |
---|
584 | return a fixnum representation of that address, else return NIL." |
---|
585 | (with-cstrs ((n name)) |
---|
586 | #+ppc-target |
---|
587 | (with-macptrs (addr) |
---|
588 | (%setf-macptr addr |
---|
589 | (ff-call (%kernel-import target::kernel-import-FindSymbol) |
---|
590 | :address handle |
---|
591 | :address n |
---|
592 | :address)) |
---|
593 | (unless (%null-ptr-p addr) ; No function can have address 0 |
---|
594 | (or (macptr->fixnum addr) (%inc-ptr addr 0)))) |
---|
595 | #+(or x8632-target arm-target) |
---|
596 | (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) |
---|
597 | :address handle |
---|
598 | :address n |
---|
599 | :unsigned-fullword))) |
---|
600 | (unless (eql 0 addr) addr)) |
---|
601 | #+x8664-target |
---|
602 | (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) |
---|
603 | :address handle |
---|
604 | :address n |
---|
605 | :unsigned-doubleword))) |
---|
606 | (unless (eql 0 addr) addr)))) |
---|
607 | |
---|
608 | (defvar *statically-linked* nil) |
---|
609 | |
---|
610 | #+(or linux-target freebsd-target solaris-target) |
---|
611 | (progn |
---|
612 | |
---|
613 | (defun %library-base-containing-address (address) |
---|
614 | (rletZ ((info :<D>l_info)) |
---|
615 | (let* ((status (ff-call *dladdr-entry* |
---|
616 | :address address |
---|
617 | :address info :signed-fullword))) |
---|
618 | (declare (integer status)) |
---|
619 | (unless (zerop status) |
---|
620 | (pref info :<D>l_info.dli_fbase))))) |
---|
621 | |
---|
622 | (defun shlib-containing-address (address &optional name) |
---|
623 | (declare (ignore name)) |
---|
624 | (let* ((base (%library-base-containing-address address))) |
---|
625 | (if base |
---|
626 | (shared-library-at base)))) |
---|
627 | |
---|
628 | |
---|
629 | (defun shlib-containing-entry (entry &optional name) |
---|
630 | (unless *statically-linked* |
---|
631 | (with-macptrs (p) |
---|
632 | (entry->addr entry p) |
---|
633 | (shlib-containing-address p name)))) |
---|
634 | ) |
---|
635 | |
---|
636 | #+darwin-target |
---|
637 | (progn |
---|
638 | (defvar *dyld-image-count*) |
---|
639 | (defvar *dyld-get-image-header*) |
---|
640 | (defvar *dyld-get-image-name*) |
---|
641 | (defvar *nslookup-symbol-in-image*) |
---|
642 | (defvar *nsaddress-of-symbol*) |
---|
643 | (defvar *nsmodule-for-symbol*) |
---|
644 | (defvar *ns-is-symbol-name-defined-in-image*) |
---|
645 | (defvar *dladdr-entry* 0) |
---|
646 | (defvar *dlopen-entry* 0) |
---|
647 | (defvar *dlerror-entry* 0) |
---|
648 | |
---|
649 | (defun setup-lookup-calls () |
---|
650 | (setq *dladdr-entry* (foreign-symbol-entry "dladdr")) |
---|
651 | (setq *dlopen-entry* (foreign-symbol-entry "dlopen")) |
---|
652 | (setq *dlerror-entry* (foreign-symbol-entry "dlerror")) |
---|
653 | (setq *dyld-image-count* (foreign-symbol-entry "_dyld_image_count")) |
---|
654 | (setq *dyld-get-image-header* (foreign-symbol-entry "_dyld_get_image_header")) |
---|
655 | (setq *dyld-get-image-name* (foreign-symbol-entry "_dyld_get_image_name")) |
---|
656 | ) |
---|
657 | |
---|
658 | (setup-lookup-calls) |
---|
659 | |
---|
660 | (defun open-shared-library-internal (name) |
---|
661 | (with-cstrs ((cname name)) |
---|
662 | (let* ((handle (ff-call *dlopen-entry* |
---|
663 | :address cname |
---|
664 | :int (logior #$RTLD_GLOBAL #$RTLD_NOW) |
---|
665 | :address))) |
---|
666 | (if (%null-ptr-p handle) |
---|
667 | (values nil (%get-cstring (ff-call *dlerror-entry* :address))) |
---|
668 | (let* ((lib (shared-library-with-handle handle))) |
---|
669 | (unless lib |
---|
670 | (setq lib (%cons-shlib name name nil nil)) |
---|
671 | (setf (shlib.handle lib) handle) |
---|
672 | (push lib *shared-libraries*)) |
---|
673 | (incf (shlib.opencount lib)) |
---|
674 | (values lib nil)))))) |
---|
675 | |
---|
676 | ;;; |
---|
677 | ;;; When restarting from a saved image |
---|
678 | ;;; |
---|
679 | (defun reopen-user-libraries () |
---|
680 | (dolist (lib *shared-libraries*) |
---|
681 | (setf (shlib.handle lib) nil |
---|
682 | (shlib.base lib) nil)) |
---|
683 | (dolist (lib *shared-libraries*) |
---|
684 | (with-cstrs ((cname (shlib.soname lib))) |
---|
685 | (let* ((handle (ff-call *dlopen-entry* |
---|
686 | :address cname |
---|
687 | :int (logior #$RTLD_GLOBAL #$RTLD_NOW) |
---|
688 | :address))) |
---|
689 | (unless (%null-ptr-p handle) |
---|
690 | (setf (shlib.handle lib) handle)))))) |
---|
691 | |
---|
692 | (defun shlib-containing-address (address &optional name) |
---|
693 | (declare (ignore name)) |
---|
694 | (%stack-block ((info (record-length #>Dl_info) :clear t)) |
---|
695 | (unless (zerop (ff-call *dladdr-entry* |
---|
696 | :address address |
---|
697 | :address info |
---|
698 | :signed-fullword)) |
---|
699 | (let* ((addr (pref info #>Dl_info.dli_fbase)) |
---|
700 | (name (%get-cstring (pref info #>Dl_info.dli_fname))) |
---|
701 | (namelen (length name))) |
---|
702 | (dolist (lib *shared-libraries*) |
---|
703 | (let* ((shlibname (shlib.pathname lib)) |
---|
704 | (shlibnamelen (length shlibname))) |
---|
705 | (when (%simple-string= name shlibname 0 0 namelen shlibnamelen) |
---|
706 | (unless (shlib.base lib) |
---|
707 | (setf (shlib.base lib) addr |
---|
708 | (shlib.soname lib) (soname-from-mach-header addr))) |
---|
709 | (return lib)))))))) |
---|
710 | |
---|
711 | (defun shlib-containing-entry (entry &optional name) |
---|
712 | (unless name |
---|
713 | (error "foreign name must be non-NIL.")) |
---|
714 | (with-macptrs (addr) |
---|
715 | (entry->addr entry addr) |
---|
716 | (shlib-containing-address addr name))) |
---|
717 | |
---|
718 | (defun soname-from-mach-header (header) |
---|
719 | (do* ((p (%inc-ptr header |
---|
720 | #+64-bit-target (record-length :mach_header_64) |
---|
721 | #-64-bit-target (record-length :mach_header)) |
---|
722 | (%inc-ptr p (pref p :load_command.cmdsize))) |
---|
723 | (i 0 (1+ i)) |
---|
724 | (n (pref header |
---|
725 | #+64-bit-target :mach_header_64.ncmds |
---|
726 | #-64-bit-target :mach_header.ncmds))) |
---|
727 | ((= i n)) |
---|
728 | (when (= #$LC_ID_DYLIB (pref p :load_command.cmd)) |
---|
729 | (return (%get-cstring (%inc-ptr p (record-length :dylib_command))))))) |
---|
730 | |
---|
731 | |
---|
732 | |
---|
733 | |
---|
734 | (defun init-shared-libraries () |
---|
735 | (do* ((count (ff-call *dyld-image-count* :unsigned-fullword)) |
---|
736 | (i 1 (1+ i))) |
---|
737 | ((= i count)) |
---|
738 | (declare (fixnum i count)) |
---|
739 | (let* ((addr (ff-call *dyld-get-image-header* :unsigned-fullword i :address)) |
---|
740 | (nameptr (ff-call *dyld-get-image-name* :unsigned-fullword i :address)) |
---|
741 | (name (%get-cstring nameptr )) |
---|
742 | (lib (%cons-shlib (soname-from-mach-header addr) name nil addr))) |
---|
743 | (setf (shlib.handle lib) |
---|
744 | (ff-call *dlopen-entry* :address nameptr :unsigned-fullword (logior #$RTLD_GLOBAL #$RTLD_NOLOAD))) |
---|
745 | (push lib *shared-libraries*)))) |
---|
746 | |
---|
747 | (init-shared-libraries) |
---|
748 | |
---|
749 | ;; end Darwin progn |
---|
750 | ) |
---|
751 | |
---|
752 | #-(or linux-target darwin-target freebsd-target solaris-target windows-target) |
---|
753 | (defun shlib-containing-entry (entry &optional name) |
---|
754 | (declare (ignore entry name)) |
---|
755 | *rtld-default*) |
---|
756 | |
---|
757 | |
---|
758 | (defun resolve-eep (e &optional (require-resolution t)) |
---|
759 | (or (eep.address e) |
---|
760 | (let* ((name (eep.name e)) |
---|
761 | (container (eep.container e)) |
---|
762 | (handle (resolve-container container require-resolution)) |
---|
763 | (addr (foreign-symbol-entry name handle))) |
---|
764 | (if addr |
---|
765 | (progn |
---|
766 | (unless container |
---|
767 | (setf (eep.container e) (shlib-containing-entry addr name))) |
---|
768 | (setf (eep.address e) addr)) |
---|
769 | (if require-resolution |
---|
770 | (error "Can't resolve foreign symbol ~s" name)))))) |
---|
771 | |
---|
772 | |
---|
773 | |
---|
774 | (defun foreign-symbol-address (name &optional (map *rtld-use*)) |
---|
775 | "Try to resolve the address of the foreign symbol name. If successful, |
---|
776 | return that address encapsulated in a MACPTR, else returns NIL." |
---|
777 | (with-cstrs ((n name)) |
---|
778 | (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address))) |
---|
779 | (unless (%null-ptr-p addr) |
---|
780 | addr)))) |
---|
781 | |
---|
782 | (defun resolve-foreign-variable (fv &optional (require-resolution t)) |
---|
783 | (or (fv.addr fv) |
---|
784 | (let* ((name (fv.name fv)) |
---|
785 | (container (fv.container fv)) |
---|
786 | (handle (resolve-container container require-resolution)) |
---|
787 | (addr (foreign-symbol-address name handle))) |
---|
788 | (if addr |
---|
789 | (progn |
---|
790 | (unless container |
---|
791 | (setf (fv.container fv) (shlib-containing-address addr name))) |
---|
792 | (setf (fv.addr fv) addr)) |
---|
793 | (if require-resolution |
---|
794 | (error "Can't resolve foreign symbol ~s" name)))))) |
---|
795 | |
---|
796 | (defun load-eep (name) |
---|
797 | (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name))))) |
---|
798 | (resolve-eep eep nil) |
---|
799 | eep)) |
---|
800 | |
---|
801 | (defun load-fv (name type) |
---|
802 | (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type))))) |
---|
803 | (resolve-foreign-variable fv nil) |
---|
804 | fv)) |
---|
805 | |
---|
806 | |
---|
807 | |
---|
808 | |
---|
809 | |
---|
810 | |
---|
811 | #+(or linux-target freebsd-target solaris-target) |
---|
812 | (progn |
---|
813 | |
---|
814 | ;;; Return the position of the last dot character in name, if that |
---|
815 | ;;; character is followed by one or more decimal digits (e.g., the |
---|
816 | ;;; start of a numeric suffix on a library name.) Return NIL if |
---|
817 | ;;; there's no such suffix. |
---|
818 | (defun last-dot-pos (name) |
---|
819 | (do* ((i (1- (length name)) (1- i)) |
---|
820 | (default i) |
---|
821 | (trailing-digits nil)) |
---|
822 | ((<= i 0) default) |
---|
823 | (declare (fixnum i)) |
---|
824 | (let* ((code (%scharcode name i))) |
---|
825 | (declare (type (mod #x110000) code)) |
---|
826 | (if (and (>= code (char-code #\0)) |
---|
827 | (<= code (char-code #\9))) |
---|
828 | (setq trailing-digits t) |
---|
829 | (if (= code (char-code #\.)) |
---|
830 | (return (if trailing-digits i)) |
---|
831 | (return default)))))) |
---|
832 | |
---|
833 | ;;; It's assumed that the set of libraries that the OS has open |
---|
834 | ;;; (accessible via the _dl_loaded global variable) is a subset of |
---|
835 | ;;; the libraries on *shared-libraries*. |
---|
836 | |
---|
837 | (defun revive-shared-libraries () |
---|
838 | (dolist (lib *shared-libraries*) |
---|
839 | (setf (shlib.map lib) nil |
---|
840 | (shlib.pathname lib) nil |
---|
841 | (shlib.base lib) nil) |
---|
842 | (let* ((soname (shlib.soname lib)) |
---|
843 | (last-dot (if soname (last-dot-pos soname)))) |
---|
844 | (when soname |
---|
845 | (with-cstrs ((soname soname)) |
---|
846 | (let* ((map (block found |
---|
847 | (%walk-shared-libraries |
---|
848 | #'(lambda (m) |
---|
849 | (with-macptrs (libname) |
---|
850 | (%setf-macptr libname |
---|
851 | (soname-ptr-from-link-map m)) |
---|
852 | (unless (%null-ptr-p libname) |
---|
853 | (when (or (%cstrcmp soname libname) |
---|
854 | (and last-dot |
---|
855 | (%cnstrcmp soname libname (1+ last-dot)))) |
---|
856 | (return-from found m))))))))) |
---|
857 | (when map |
---|
858 | ;;; Sigh. We can't reliably lookup symbols in the library |
---|
859 | ;;; unless we open the library (which is, of course, |
---|
860 | ;;; already open ...) ourselves, passing in the |
---|
861 | ;;; #$RTLD_GLOBAL flag. |
---|
862 | #+linux-target |
---|
863 | (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) |
---|
864 | :address soname |
---|
865 | :unsigned-fullword *dlopen-flags* |
---|
866 | :void) |
---|
867 | (setf (shlib.base lib) (link_map.l_addr map) |
---|
868 | (shlib.pathname lib) (%get-cstring |
---|
869 | (pref map :link_map.l_name)) |
---|
870 | (shlib.soname lib) (%get-cstring (soname-ptr-from-link-map map)) |
---|
871 | (shlib.map lib) map)))))))) |
---|
872 | |
---|
873 | ;;; Repeatedly iterate over shared libraries, trying to open those |
---|
874 | ;;; that weren't already opened by the kernel. Keep doing this until |
---|
875 | ;;; we reach stasis (no failures or no successes.) |
---|
876 | |
---|
877 | (defun %reopen-user-libraries () |
---|
878 | (loop |
---|
879 | (let* ((win nil) |
---|
880 | (lose nil)) |
---|
881 | (dolist (lib *shared-libraries*) |
---|
882 | (let* ((map (shlib.map lib)) |
---|
883 | (handle (shlib.handle lib))) |
---|
884 | (unless map |
---|
885 | (with-cstrs ((soname (shlib.soname lib))) |
---|
886 | (setq handle |
---|
887 | (ff-call |
---|
888 | (%kernel-import target::kernel-import-GetSharedLibrary) |
---|
889 | :address soname |
---|
890 | :unsigned-fullword *dlopen-flags* |
---|
891 | :address)) |
---|
892 | #-(or freebsd-target solaris-target) (setq map handle) |
---|
893 | #+(or freebsd-target solaris-target) |
---|
894 | (setq map |
---|
895 | (if (%null-ptr-p handle) |
---|
896 | handle |
---|
897 | (rlet ((p :address)) |
---|
898 | (if (eql 0 (ff-call |
---|
899 | (foreign-symbol-entry "dlinfo") |
---|
900 | :address handle |
---|
901 | :int #$RTLD_DI_LINKMAP |
---|
902 | :address p |
---|
903 | :int)) |
---|
904 | (pref p :address) |
---|
905 | (%null-ptr))))) |
---|
906 | (if (%null-ptr-p map) |
---|
907 | (setq lose t) |
---|
908 | (setf (shlib.pathname lib) |
---|
909 | (%get-cstring (pref map :link_map.l_name)) |
---|
910 | (shlib.base lib) |
---|
911 | (link_map.l_addr map) |
---|
912 | (shlib.map lib) map |
---|
913 | (shlib.handle lib) handle |
---|
914 | win t)))))) |
---|
915 | (when (or (not lose) (not win)) (return))))) |
---|
916 | ) |
---|
917 | |
---|
918 | |
---|
919 | (defun refresh-external-entrypoints () |
---|
920 | #+linux-target |
---|
921 | (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked)))) |
---|
922 | (%revive-macptr *rtld-next*) |
---|
923 | (%revive-macptr *rtld-default*) |
---|
924 | #+(or linux-target freebsd-target solaris-target) |
---|
925 | (unless *statically-linked* |
---|
926 | (setq *dladdr-entry* (foreign-symbol-entry "dladdr")) |
---|
927 | (revive-shared-libraries) |
---|
928 | (%reopen-user-libraries)) |
---|
929 | #+darwin-target |
---|
930 | (progn |
---|
931 | (setup-lookup-calls) |
---|
932 | (reopen-user-libraries)) |
---|
933 | #+windows-target |
---|
934 | (progn |
---|
935 | (init-windows-ffi) |
---|
936 | (revive-shared-libraries) |
---|
937 | (reopen-user-libraries)) |
---|
938 | (when *eeps* |
---|
939 | (without-interrupts |
---|
940 | (maphash #'(lambda (k v) |
---|
941 | (declare (ignore k)) |
---|
942 | (setf (eep.address v) nil) |
---|
943 | (resolve-eep v nil)) |
---|
944 | *eeps*))) |
---|
945 | (when *fvs* |
---|
946 | (without-interrupts |
---|
947 | (maphash #'(lambda (k v) |
---|
948 | (declare (ignore k)) |
---|
949 | (setf (fv.addr v) nil) |
---|
950 | (resolve-foreign-variable v nil)) |
---|
951 | *fvs*)))) |
---|
952 | |
---|
953 | (defun open-shared-library (name &optional (process #+darwin-target :initial |
---|
954 | #-darwin-target :current)) |
---|
955 | "If the library denoted by name can be loaded by the operating system, |
---|
956 | return an object of type SHLIB that describes the library; if the library |
---|
957 | is already open, increment a reference count. If the library can't be |
---|
958 | loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from |
---|
959 | the operating system." |
---|
960 | (multiple-value-bind (lib error-string) |
---|
961 | (if (or (eq process :current) |
---|
962 | (eq process *current-process*) |
---|
963 | (and (eq process :initial) |
---|
964 | (eq *current-process* *initial-process*))) |
---|
965 | (open-shared-library-internal name) |
---|
966 | |
---|
967 | (call-in-process (lambda () |
---|
968 | (handler-case (open-shared-library-internal name) |
---|
969 | (error (condition) (values nil (format nil "~a" condition))))) |
---|
970 | |
---|
971 | |
---|
972 | (if (eq process :initial) |
---|
973 | *initial-process* |
---|
974 | process))) |
---|
975 | (or lib |
---|
976 | (error "Error opening shared library ~a : ~a." name error-string)))) |
---|
977 | |
---|
978 | |
---|