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

Last change on this file since 7591 was 7591, checked in by gb, 12 years ago

Hack wouldn't work on FreeBSD; try conditionalized hack.

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