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

Last change on this file since 6484 was 6484, checked in by gb, 14 years ago

Remove an old declaration.

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