source: trunk/source/level-0/l0-cfm-support.lisp @ 8587

Last change on this file since 8587 was 8587, checked in by gb, 13 years ago

On ELF platforms, distinguish between link-map and handle returned
by #_dlopen. (They're EQL on Linux but differ on FreeBSD.) Note
that we only set the handle for libraries opened explicitly by
user code, which allows us to usurp the old opened-by-lisp-kernel
slot.

Ensure that CLOSE-SHARED-LIBRARY is defined on FreeBSD; make the ELF
version call #_dlclose on the handle if it exists, not the link map.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 26.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17
18; l0-cfm-support.lisp
19
20(in-package "CCL")
21
22
23
24
25
26
27
28
29;;; Bootstrapping. Real version is in l1-aprims.
30;;; Called by expansion of with-pstrs
31
32(defun byte-length (string &optional script start end)
33    (declare (ignore script))
34    (when (or start end)
35      (error "Don't support start or end args yet"))
36    (if (base-string-p string)
37      (length string)
38      (error "Don't support non base-string yet.")))
39
40
41
42(def-accessor-macros %svref
43  nil                                 ; 'external-entry-point
44  eep.address
45  eep.name
46  eep.container)
47
48(defun %cons-external-entry-point (name &optional container)
49  (%istruct 'external-entry-point nil name container))
50
51(defun external-entry-point-p (x)
52  (istruct-typep x 'external-entry-point))
53
54(def-accessor-macros %svref
55    nil                                 ;'foreign-variable
56  fv.addr                               ; a MACPTR, or nil
57  fv.name                               ; a string
58  fv.type                               ; a foreign type
59  fv.container                          ; containing library
60  )
61
62(defun %cons-foreign-variable (name type &optional container)
63  (%istruct 'foreign-variable nil name type container))
64
65(def-accessor-macros %svref
66    nil                                 ;'shlib
67  shlib.soname
68  shlib.pathname
69  shlib.handle                          ; if explicitly opened
70  shlib.map
71  shlib.base
72  shlib.opencount)
73
74(defun %cons-shlib (soname pathname map base)
75  (%istruct 'shlib soname pathname nil map base 0))
76
77(defvar *rtld-next*)
78(defvar *rtld-default*)
79(setq *rtld-next* (%incf-ptr (%null-ptr) -1)
80      *rtld-default* (%int-to-ptr #+(or linux-target darwin-target)  0
81                                  #-(or linux-target darwin-target)  -2))
82
83#+(or linux-target freebsd-target)
84(progn
85
86(defvar *dladdr-entry*)
87 
88;;; I can't think of a reason to change this.
89(defvar *dlopen-flags* nil)
90(setq *dlopen-flags* (logior #$RTLD_GLOBAL #$RTLD_NOW))
91)
92
93(defvar *eeps* nil)
94
95(defvar *fvs* nil)
96
97(defun eeps ()
98  (or *eeps*
99      (setq *eeps* (make-hash-table :test #'equal))))
100
101(defun fvs ()
102  (or *fvs*
103      (setq *fvs* (make-hash-table :test #'equal))))
104
105(defun unload-foreign-variables (lib)
106  (let* ((fvs (fvs)))
107    (when fvs
108      (maphash #'(lambda (k fv)
109                   (declare (ignore k))
110                   (when (eq (fv.container fv) lib)
111                     (setf (fv.addr fv) nil)))
112               fvs))))
113
114(defun generate-external-functions (path)
115  (let* ((names ()))
116    (maphash #'(lambda (k ignore)
117                 (declare (ignore ignore))
118                 (push k names)) (eeps))
119    (with-open-file (stream path
120                            :direction :output
121                            :if-exists :supersede
122                            :if-does-not-exist :create)
123      (dolist (k names) (format stream "~&extern void * ~a();" k))
124     
125      (format stream "~&external_function external_functions[] = {")
126      (dolist (k names) (format stream "~&~t{~s,~a}," k k))
127      (format stream "~&~t{0,0}~&};"))))
128
129   
130(defvar *shared-libraries* nil)
131
132#+(or linux-target freebsd-target)
133(progn
134
135(defun soname-ptr-from-link-map (map)
136  (with-macptrs ((dyn-strings)
137                 (dynamic-entries (pref map :link_map.l_ld)))
138    (let* ((soname-offset nil))
139      ;; Walk over the entries in the file's dynamic segment; the
140      ;; last such entry will have a tag of #$DT_NULL.  Note the
141      ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD)
142      ;; address of the dynamic string table and the offset of the
143      ;; #$DT_SONAME string in that string table.
144      ;; Actually, the above isn't quite right; there seem to
145      ;; be cases (involving vDSO) where the address of a library's
146      ;; dynamic string table is expressed as an offset relative
147      ;; to link_map.l_addr as well.
148      (loop
149          (case #+32-bit-target (pref dynamic-entries :<E>lf32_<D>yn.d_tag)
150                #+64-bit-target (pref dynamic-entries :<E>lf64_<D>yn.d_tag)
151            (#. #$DT_NULL (return))
152            (#. #$DT_SONAME
153                (setq soname-offset
154                      #+32-bit-target (pref dynamic-entries
155                                           :<E>lf32_<D>yn.d_un.d_val)
156                      #+64-bit-target (pref dynamic-entries
157                                           :<E>lf64_<D>yn.d_un.d_val)))
158            (#. #$DT_STRTAB
159                (%setf-macptr dyn-strings
160                              ;; Try to guess whether we're dealing
161                              ;; with a displacement or with an
162                              ;; absolute address.  There may be
163                              ;; a better way to determine this,
164                              ;; but for now we assume that absolute
165                              ;; addresses aren't negative and that
166                              ;; displacements are.
167                               (let* ((disp (%get-signed-natural
168                                             dynamic-entries
169                                             target::node-size)))
170                                 #+freebsd-target
171                                 (%inc-ptr (pref map :link_map.l_addr) disp)
172                                 #-freebsd-target
173                                 (%int-to-ptr 
174                                  (if (< disp 0) 
175                                    (+ disp (pref map :link_map.l_addr))
176                                    disp))))))
177          (%setf-macptr dynamic-entries
178                        (%inc-ptr dynamic-entries
179                                  #+32-bit-target
180                                  (record-length :<E>lf32_<D>yn)
181                                  #+64-bit-target
182                                  (record-length :<E>lf64_<D>yn))))
183      (if (and soname-offset
184               (not (%null-ptr-p dyn-strings)))
185        (%inc-ptr dyn-strings soname-offset)
186        ;; Use the full pathname of the library.
187        (pref map :link_map.l_name)))))
188
189(defun shared-library-at (base)
190  (dolist (lib *shared-libraries*)
191    (when (eql (shlib.base lib) base)
192      (return lib))))
193
194(defun shared-library-with-name (name)
195  (let* ((namelen (length name)))
196    (dolist (lib *shared-libraries*)
197      (let* ((libname (shlib.soname lib)))
198        (when (%simple-string= name libname 0 0 namelen (length libname))
199          (return lib))))))
200
201(defun shlib-from-map-entry (m)
202  (let* ((base (%int-to-ptr (pref m :link_map.l_addr))))
203    ;; On relatively modern Linux systems, this is often NULL.
204    ;; I'm not sure what (SELinux ?  Pre-binding ?  Something else ?)
205    ;; counts as being "relatively modern" in this case.
206    ;; The link-map's l_ld field is a pointer to the .so's dynamic
207    ;; section, and #_dladdr seems to recognize that as being an
208    ;; address within the library and returns a reasonable "base address".
209    (when (%null-ptr-p base)
210      (let* ((addr (%library-base-containing-address (pref m :link_map.l_ld))))
211        (if addr (setq base addr))))
212    (or (let* ((existing-lib (shared-library-at base)))
213          (when (and existing-lib (null (shlib.map existing-lib)))
214            (setf (shlib.map existing-lib) m
215                  (shlib.pathname existing-lib)
216                  (%get-cstring (pref m :link_map.l_name))
217                  (shlib.base existing-lib) base))
218          existing-lib)
219        (let* ((soname-ptr (soname-ptr-from-link-map m))
220               (soname (unless (%null-ptr-p soname-ptr) (%get-cstring soname-ptr)))
221               (pathname (%get-cstring (pref m :link_map.l_name)))
222               (shlib (shared-library-with-name soname)))
223          (if shlib
224            (setf (shlib.map shlib) m
225                  (shlib.base shlib) base
226                  (shlib.pathname shlib) pathname)
227            (push (setq shlib (%cons-shlib soname pathname m base))
228                  *shared-libraries*))
229          shlib))))
230
231
232(defun %get-r-debug ()
233  (let* ((addr (ff-call (%kernel-import target::kernel-import-get-r-debug)
234                        address)))
235    (unless (%null-ptr-p addr)
236      addr)))
237
238(defun %link-map-address ()
239  (let* ((r_debug (%get-r-debug)))
240    (if r_debug
241      (pref r_debug :r_debug.r_map)
242      (let* ((p (or (foreign-symbol-address "_dl_loaded")
243                    (foreign-symbol-address "_rtld_global"))))
244        (if p
245          (%get-ptr p))))))
246
247(defun %walk-shared-libraries (f)
248  (let* ((loaded (%link-map-address)))
249    (do* ((map (pref loaded :link_map.l_next) (pref map :link_map.l_next)))
250         ((%null-ptr-p map))
251      (funcall f map))))
252
253
254(defun %dlopen-shlib (l)
255  (with-cstrs ((n (shlib.soname l)))
256    (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
257             :address n
258             :unsigned-fullword *dlopen-flags*
259             :void)))
260 
261(defun init-shared-libraries ()
262  (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
263  (when (null *shared-libraries*)
264    (%walk-shared-libraries #'shlib-from-map-entry)
265      ;;; On Linux, it seems to be necessary to open each of these
266      ;;; libraries yet again, specifying the RTLD_GLOBAL flag.
267      ;;; On FreeBSD, it seems desirable -not- to do that.
268    #+linux-target
269    (dolist (l *shared-libraries*)
270      (%dlopen-shlib l))))
271
272(init-shared-libraries)
273
274;;; Walk over all registered entrypoints, invalidating any whose container
275;;; is the specified library.  Return true if any such entrypoints were
276;;; found.
277(defun unload-library-entrypoints (lib)
278  (let* ((count 0))
279    (declare (fixnum count))
280    (maphash #'(lambda (k eep)
281                 (declare (ignore k))
282                 (when (eq (eep.container eep) lib)
283                   (setf (eep.address eep) nil)
284                   (incf count)))
285             (eeps))   
286    (not (zerop count))))
287
288
289                     
290                     
291
292(defun open-shared-library (name)
293  "If the library denoted by name can be loaded by the operating system,
294return an object of type SHLIB that describes the library; if the library
295is already open, increment a reference count. If the library can't be
296loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
297the operating system."
298  (let* ((handle (with-cstrs ((name name))
299                        (ff-call
300                         (%kernel-import target::kernel-import-GetSharedLibrary)
301                         :address name
302                         :unsigned-fullword *dlopen-flags*
303                         :address)))
304         (link-map #-freebsd-target handle
305                   #+freebsd-target (if (%null-ptr-p handle)
306                                      handle
307                                      (rlet ((p :address))
308                                        (if (eql 0 (ff-call
309                                                    (foreign-symbol-entry "dlinfo")
310                                                    :address handle
311                                                    :int #$RTLD_DI_LINKMAP
312                                                    :address p
313                                                    :int))
314                                          (pref p :address)
315                                          (%null-ptr))))))
316    (if (%null-ptr-p link-map)
317      (error "Error opening shared library ~s: ~a" name (dlerror))
318      (prog1 (let* ((lib (shlib-from-map-entry link-map)))
319               (incf (shlib.opencount lib))
320               (setf (shlib.handle lib) handle)
321               lib)
322        (%walk-shared-libraries
323         #'(lambda (map)
324             (unless (shared-library-at
325                      (%int-to-ptr (pref map :link_map.l_addr)))
326               (let* ((new (shlib-from-map-entry map)))
327                 (%dlopen-shlib new)))))))))
328
329)
330
331
332#+darwin-target
333(progn
334
335(defun shared-library-with-header (header)
336  (dolist (lib *shared-libraries*)
337    (when (eql (shlib.map lib) header)
338      (return lib))))
339
340(defun shared-library-with-module (module)
341  (dolist (lib *shared-libraries*)
342    (when (eql (shlib.base lib) module)
343      (return lib))))
344
345(defun shared-library-with-name (name &optional (is-unloaded nil))
346  (let* ((namelen (length name)))
347    (dolist (lib *shared-libraries*)
348      (let* ((libname (shlib.soname lib)))
349        (when (and (%simple-string= name libname 0 0 namelen (length libname))
350                   (or (not is-unloaded) (and (null (shlib.map lib))
351                                              (null (shlib.base lib)))))
352          (return lib))))))
353
354;;;   
355;;; maybe we could fix this up name to get the "real name"
356;;; this is might be possible for dylibs but probably not for modules
357;;; for now soname and pathname are just the name that the user passed in
358;;; if the library is "discovered" later, it is the name the system gave
359;;; to it -- usually a full pathname
360;;;
361;;; header and module are ptr types
362;;;
363(defun shared-library-from-header-module-or-name (header module name)
364  ;; first try to find the library based on its address
365  (let ((found-lib (if (%null-ptr-p module)
366                       (shared-library-with-header header)
367                     (shared-library-with-module module))))
368   
369    (unless found-lib
370      ;; check if the library name is still on our list but has been unloaded
371      (setq found-lib (shared-library-with-name name t))
372      (if found-lib
373        (setf (shlib.map found-lib) header
374              (shlib.base found-lib) module)
375        ;; otherwise add it to the list
376        (push (setq found-lib (%cons-shlib name name header module))
377              *shared-libraries*)))
378    found-lib))
379
380
381(defun open-shared-library (name)
382  "If the library denoted by name can be loaded by the operating system,
383return an object of type SHLIB that describes the library; if the library
384is already open, increment a reference count. If the library can't be
385loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
386the operating system."
387  (rlet ((type :signed))
388    (let ((result (with-cstrs ((cname name))
389                    (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
390                             :address cname
391                             :address type
392                             :address))))
393        (cond
394         ((= 1 (pref type :signed))
395          ;; dylib
396          (shared-library-from-header-module-or-name result (%null-ptr) name))
397         ((= 2 (pref type :signed))
398          ;; bundle
399          (shared-library-from-header-module-or-name (%null-ptr) result name))
400         ((= 0 (pref type :signed))
401          ;; neither a dylib nor bundle was found
402          (error "Error opening shared library ~s: ~a" name
403                 (%get-cstring result)))
404         (t (error "Unknown error opening shared library ~s." name))))))
405
406;;; Walk over all registered entrypoints, invalidating any whose container
407;;; is the specified library.  Return true if any such entrypoints were
408;;; found.
409;;;
410;;; SAME AS LINUX VERSION
411;;;
412(defun unload-library-entrypoints (lib)
413  (let* ((count 0))
414    (declare (fixnum count))
415    (maphash #'(lambda (k eep)
416                 (declare (ignore k))
417                 (when (eq (eep.container eep) lib)
418                   (setf (eep.address eep) nil)
419                   (incf count)))
420             (eeps))   
421    (not (zerop count))))
422
423;;;
424;;; When restarting from a saved image
425;;;
426(defun reopen-user-libraries ()
427  (dolist (lib *shared-libraries*)
428    (setf (shlib.map lib) nil
429          (shlib.base lib) nil))
430  (loop
431      (let* ((win nil)
432             (lose nil))
433        (dolist (lib *shared-libraries*)
434          (let* ((header (shlib.map lib))
435                 (module (shlib.base lib)))
436            (unless (and header module)
437              (rlet ((type :signed))
438                (let ((result (with-cstrs ((cname (shlib.soname lib)))
439                                (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
440                                         :address cname
441                                         :address type
442                                         :address))))
443                  (cond
444                   ((= 1 (pref type :signed))
445                    ;; dylib
446                    (setf (shlib.map lib) result
447                          (shlib.base lib) (%null-ptr)
448                          win t))
449                   ((= 2 (pref type :signed))
450                    ;; bundle
451                    (setf (shlib.map lib) (%null-ptr)
452                          (shlib.base lib) result
453                          win t))
454                   (t
455                    ;; neither a dylib nor bundle was found
456                    (setq lose t))))))))
457        (when (or (not lose) (not win)) (return)))))
458
459;;; end darwin-target
460) 
461
462
463(defun ensure-open-shlib (c force)
464  (if (or (shlib.map c) (not force))
465    *rtld-default*
466    (error "Shared library not open: ~s" (shlib.soname c))))
467
468(defun resolve-container (c force)
469  (if c
470    (ensure-open-shlib c force)
471    *rtld-default*
472    ))
473
474
475
476
477;;; An "entry" can be fixnum (the low 2 bits are clear) which represents
478;;; a (32-bit word)-aligned address.  That convention covers all
479;;; function addresses on ppc32 and works for addresses that are
480;;; 0 mod 8 on PPC64, but can't work for things that're byte-aligned
481;;; (x8664 and other non-RISC platforms.)
482;;; For PPC64, we may have to cons up a macptr if people use broken
483;;; linkers.  (There are usually cache advantages to aligning ppc
484;;; function addresses on at least a 16-byte boundary, but some
485;;; linkers don't quite get the concept ...)
486
487(defun foreign-symbol-entry (name &optional (handle *rtld-default*))
488  "Try to resolve the address of the foreign symbol name. If successful,
489return a fixnum representation of that address, else return NIL."
490  (with-cstrs ((n name))
491    #+ppc-target
492    (with-macptrs (addr)     
493      (%setf-macptr addr
494                    (ff-call (%kernel-import target::kernel-import-FindSymbol)
495                             :address handle
496                             :address n
497                             :address))
498      (unless (%null-ptr-p addr)        ; No function can have address 0
499        (or (macptr->fixnum addr) (%inc-ptr addr 0))))
500    #+x8664-target
501    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
502                          :address handle
503                          :address n
504                          :unsigned-doubleword)))
505      (unless (eql 0 addr) addr))))
506
507(defvar *statically-linked* nil)
508
509#+(or linux-target freebsd-target)
510(progn
511
512(defun %library-base-containing-address (address)
513  (rletZ ((info :<D>l_info))
514    (let* ((status (ff-call *dladdr-entry*
515                            :address address
516                            :address info :signed-fullword)))
517      (declare (integer status))
518      (unless (zerop status)
519        (pref info :<D>l_info.dli_fbase)))))
520 
521(defun shlib-containing-address (address &optional name)
522  (declare (ignore name))
523  (let* ((base (%library-base-containing-address address)))
524    (if base
525      (shared-library-at base))))
526
527
528(defun shlib-containing-entry (entry &optional name)
529  (unless *statically-linked*
530    (with-macptrs (p)
531      (%setf-macptr-to-object p entry)
532      (shlib-containing-address p name))))
533)
534
535#+darwin-target
536(progn
537(defvar *dyld-image-count*)
538(defvar *dyld-get-image-header*)
539(defvar *dyld-get-image-name*)
540(defvar *nslookup-symbol-in-image*)
541(defvar *nsaddress-of-symbol*)
542(defvar *nsmodule-for-symbol*)
543(defvar *ns-is-symbol-name-defined-in-image*)
544
545(defun setup-lookup-calls ()
546  (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count"))
547  (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header"))
548  (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name"))
549  (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage"))
550  (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol"))
551  (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol"))
552  (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage")))
553
554(setup-lookup-calls)
555
556;;;
557;;; given an entry address (a number) and a symbol name (lisp string)
558;;; find the associated dylib or module
559;;; if the dylib or module is not found in *shared-libraries* list it is added
560;;; if not found in the OS list it returns nil
561;;;
562;;; got this error before putting in the call to
563;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead
564;;; lock (dyld operation attempted in a thread already doing a dyld
565;;; operation)
566;;;
567
568(defun shlib-containing-address (addr name)
569  (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword))
570    (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address)))
571      (when (and (not (%null-ptr-p header))
572                 (or (eql (pref header :mach_header.filetype) #$MH_DYLIB)
573                     (eql (pref header :mach_header.filetype) #$MH_BUNDLE)))
574        ;; make sure the image is either a bundle or a dylib
575        ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5)
576        (with-cstrs ((cname name))
577          ;; also we must check is symbol name is defined in the
578          ;; image otherwise in certain cases there is a crash,
579          ;; another likely OS bug happens in the case where a
580          ;; bundle imports a dylib and then we call
581          ;; nslookupsymbolinimage on the bundle image
582          (when (/= 0
583                    (ff-call *ns-is-symbol-name-defined-in-image* :address header
584                             :address cname :unsigned))
585            (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname
586                                   :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR
587                                   :address)))
588              (unless (%null-ptr-p symbol)
589                ;; compare the found address to the address we are looking for
590                (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address)))
591                  ;; (format t "Foundaddr ~s~%" foundaddr)
592                  ;; (format t "Compare to addr ~s~%" addr)
593                  (when (eql foundaddr addr)
594                    (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
595                           (libname (unless (%null-ptr-p imgname) (%get-cstring imgname)))
596                           (libmodule (%int-to-ptr 0))
597                           (libheader (%int-to-ptr 0)))
598                      (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE)
599                        (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address))
600                        (setf libheader header))
601                      ;; make sure that this shared library is on *shared-libraries*
602                      (return (shared-library-from-header-module-or-name libheader libmodule libname)))))))))))))
603
604(defun shlib-containing-entry (entry &optional name)
605  (when (not name)
606        (error "shared library name must be non-NIL."))
607  (with-macptrs (addr)
608    (%setf-macptr-to-object addr entry)
609    (shlib-containing-address addr name)))
610
611;; end Darwin progn
612)
613
614#-(or linux-target darwin-target freebsd-target)
615(defun shlib-containing-entry (entry &optional name)
616  (declare (ignore entry name))
617  *rtld-default*)
618
619
620(defun resolve-eep (e &optional (require-resolution t))
621  (or (eep.address e)
622      (let* ((name (eep.name e))
623             (container (eep.container e))
624             (handle (resolve-container container require-resolution))
625             (addr (foreign-symbol-entry name handle)))
626        (if addr
627          (progn
628            (unless container
629              (setf (eep.container e) (shlib-containing-entry addr name)))
630            (setf (eep.address e) addr))
631          (if require-resolution
632            (error "Can't resolve foreign symbol ~s" name))))))
633
634
635
636(defun foreign-symbol-address (name &optional (map *rtld-default*))
637  "Try to resolve the address of the foreign symbol name. If successful,
638return that address encapsulated in a MACPTR, else returns NIL."
639  (with-cstrs ((n name))
640    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address)))
641      (unless (%null-ptr-p addr)
642        addr))))
643
644(defun resolve-foreign-variable (fv &optional (require-resolution t))
645  (or (fv.addr fv)
646      (let* ((name (fv.name fv))
647             (container (fv.container fv))
648             (handle (resolve-container container require-resolution))
649             (addr (foreign-symbol-address name handle)))
650        (if addr
651          (progn
652            (unless container
653              (setf (fv.container fv) (shlib-containing-address addr name)))
654            (setf (fv.addr fv) addr))
655          (if require-resolution
656            (error "Can't resolve foreign symbol ~s" name))))))
657
658(defun load-eep (name)
659  (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name)))))
660    (resolve-eep eep nil)
661    eep))
662
663(defun load-fv (name type)
664  (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type)))))
665    (resolve-foreign-variable fv nil)
666    fv))
667
668         
669
670
671
672
673#+(or linux-target freebsd-target)
674(progn
675;;; It's assumed that the set of libraries that the OS has open
676;;; (accessible via the _dl_loaded global variable) is a subset of
677;;; the libraries on *shared-libraries*.
678
679(defun revive-shared-libraries ()
680  (dolist (lib *shared-libraries*)
681    (setf (shlib.map lib) nil
682          (shlib.pathname lib) nil
683          (shlib.base lib) nil)
684    (let* ((soname (shlib.soname lib)))
685      (when soname
686        (with-cstrs ((soname soname))
687          (let* ((map (block found
688                        (%walk-shared-libraries
689                         #'(lambda (m)
690                             (with-macptrs (libname)
691                               (%setf-macptr libname
692                                             (soname-ptr-from-link-map m))
693                               (unless (%null-ptr-p libname)
694                                 (when (%cstrcmp soname libname)
695                                   (return-from found  m)))))))))
696            (when map
697              ;;; Sigh.  We can't reliably lookup symbols in the library
698              ;;; unless we open the library (which is, of course,
699              ;;; already open ...)  ourselves, passing in the
700              ;;; #$RTLD_GLOBAL flag.
701              #+linux-target
702              (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
703                       :address soname
704                       :unsigned-fullword *dlopen-flags*
705                       :void)
706              (setf (shlib.base lib) (%int-to-ptr (pref map :link_map.l_addr))
707                    (shlib.pathname lib) (%get-cstring
708                                          (pref map :link_map.l_name))
709                    (shlib.map lib) map))))))))
710
711;;; Repeatedly iterate over shared libraries, trying to open those
712;;; that weren't already opened by the kernel.  Keep doing this until
713;;; we reach stasis (no failures or no successes.)
714
715(defun %reopen-user-libraries ()
716  (loop
717      (let* ((win nil)
718             (lose nil))
719        (dolist (lib *shared-libraries*)
720          (let* ((map (shlib.map lib)))
721            (unless map
722              (with-cstrs ((soname (shlib.soname lib)))
723                (setq map (ff-call
724                           (%kernel-import target::kernel-import-GetSharedLibrary)
725                           :address soname
726                           :unsigned-fullword *dlopen-flags*
727                           :address))
728                (if (%null-ptr-p map)
729                  (setq lose t)
730                  (setf (shlib.pathname lib)
731                        (%get-cstring (pref map :link_map.l_name))
732                        (shlib.base lib)
733                        (%int-to-ptr (pref map :link_map.l_addr))
734                        (shlib.map lib) map
735                        win t))))))
736        (when (or (not lose) (not win)) (return)))))
737)
738
739
740(defun refresh-external-entrypoints ()
741  #+linux-target
742  (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked))))
743  (%revive-macptr *rtld-next*)
744  (%revive-macptr *rtld-default*)
745  #+(or linux-target freebsd-target)
746  (unless *statically-linked*
747    (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
748    (revive-shared-libraries)
749    (%reopen-user-libraries))
750  #+darwin-target
751  (progn
752    (setup-lookup-calls)
753    (reopen-user-libraries))
754  (when *eeps*
755    (without-interrupts 
756     (maphash #'(lambda (k v) 
757                  (declare (ignore k)) 
758                  (setf (eep.address v) nil) 
759                  (resolve-eep v nil))
760              *eeps*)))
761  (when *fvs*
762    (without-interrupts
763     (maphash #'(lambda (k v)
764                  (declare (ignore k))
765                  (setf (fv.addr v) nil)
766                  (resolve-foreign-variable v nil))
767              *fvs*))))
768
769
Note: See TracBrowser for help on using the repository browser.