source: branches/working-0711/ccl/level-0/l0-cfm-support.lisp @ 10535

Last change on this file since 10535 was 10535, checked in by gb, 11 years ago

Changes from trunk; among other things, foreign functions should
have a better idea of what shared libraries define them.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 28.9 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;;; We have several different conventions for representing an
25;;; "entry" (a foreign symbol address, possibly represented as
26;;; something cheaper than a MACPTR.)  Destructively modify
27;;; ADDR so that it points to where ENTRY points.
28(defun entry->addr (entry addr)
29  #+ppc32-target
30  ;; On PPC32, all function addresses have their low 2 bits clear;
31  ;; so do fixnums.
32  (%setf-macptr-to-object addr entry)
33  #+ppc64-target
34  ;; On PPC64, some addresses can use the fixnum trick.  In other
35  ;; cases, an "entry" is just a MACPTR.
36  (if (typep entry 'fixnum)
37    (%setf-macptr-to-object addr entry)
38    (%setf-macptr addr entry))
39  ;; On x86, an "entry" is just an integer.  There might elswehere be
40  ;; some advantage in treating those integers as signed (they might
41  ;; be more likely to be fixnums, for instance), so ensure that they
42  ;; aren't.
43  #+x86-target
44  (%setf-macptr addr (%int-to-ptr
45                      (if (< entry 0)
46                        (logand entry (1- (ash 1 target::nbits-in-word)))
47                        entry)))
48  #-(or ppc-target x86-target) (dbg "Fix entry->addr"))
49
50
51
52
53;;; Bootstrapping. Real version is in l1-aprims.
54;;; Called by expansion of with-pstrs
55
56(defun byte-length (string &optional script start end)
57    (declare (ignore script))
58    (when (or start end)
59      (error "Don't support start or end args yet"))
60    (if (base-string-p string)
61      (length string)
62      (error "Don't support non base-string yet.")))
63
64
65
66
67(defun external-entry-point-p (x)
68  (istruct-typep x 'external-entry-point))
69
70;;; On both Linux and FreeBSD, RTLD_NEXT and RTLD_DEFAULT behave
71;;; the same way wrt symbols defined somewhere other than the lisp
72;;; kernel.  On Solaris, RTLD_DEFAULT will return the address of
73;;; an imported symbol's procedure linkage table entry if the symbol
74;;; has a plt entry (e.g., if it happens to be referenced by the
75;;; lisp kernel.)  *RTLD-NEXT* is therefore a slightly better
76;;; default; we've traditionaly used *RTLD-DEFAULT*.
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 solaris-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 solaris-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                                 #+(or freebsd-target solaris-target)
171                                 (%inc-ptr (pref map :link_map.l_addr) disp)
172                                 #-(or freebsd-target solaris-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 #-(or freebsd-target solaris-target) handle
305                   #+(or freebsd-target solaris-target)
306                   (if (%null-ptr-p handle)
307                     handle
308                     (rlet ((p :address))
309                       (if (eql 0 (ff-call
310                                   (foreign-symbol-entry "dlinfo")
311                                   :address handle
312                                   :int #$RTLD_DI_LINKMAP
313                                   :address p
314                                   :int))
315                         (pref p :address)
316                         (%null-ptr))))))
317    (if (%null-ptr-p link-map)
318      (error "Error opening shared library ~s: ~a" name (dlerror))
319      (prog1 (let* ((lib (shlib-from-map-entry link-map)))
320               (incf (shlib.opencount lib))
321               (setf (shlib.handle lib) handle)
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-next*
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-next*
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-next*))
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    #+x8632-target
502    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
503                          :address handle
504                          :address n
505                          :unsigned-fullword)))
506      (unless (eql 0 addr) addr))
507    #+x8664-target
508    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
509                          :address handle
510                          :address n
511                          :unsigned-doubleword)))
512      (unless (eql 0 addr) addr))))
513
514(defvar *statically-linked* nil)
515
516#+(or linux-target freebsd-target solaris-target)
517(progn
518
519(defun %library-base-containing-address (address)
520  (rletZ ((info :<D>l_info))
521    (let* ((status (ff-call *dladdr-entry*
522                            :address address
523                            :address info :signed-fullword)))
524      (declare (integer status))
525      (unless (zerop status)
526        (pref info :<D>l_info.dli_fbase)))))
527 
528(defun shlib-containing-address (address &optional name)
529  (declare (ignore name))
530  (let* ((base (%library-base-containing-address address)))
531    (if base
532      (shared-library-at base))))
533
534
535(defun shlib-containing-entry (entry &optional name)
536  (unless *statically-linked*
537    (with-macptrs (p)
538      (entry->addr entry p)
539      (shlib-containing-address p name))))
540)
541
542#+darwin-target
543(progn
544(defvar *dyld-image-count*)
545(defvar *dyld-get-image-header*)
546(defvar *dyld-get-image-name*)
547(defvar *nslookup-symbol-in-image*)
548(defvar *nsaddress-of-symbol*)
549(defvar *nsmodule-for-symbol*)
550(defvar *ns-is-symbol-name-defined-in-image*)
551(defvar *dladdr-entry* 0)
552
553(defun setup-lookup-calls ()
554  #+notyet
555  (setq *dladdr-entry* (foreign-symbol-entry "_dladdr"))
556  (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count"))
557  (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header"))
558  (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name"))
559  (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage"))
560  (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol"))
561  (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol"))
562  (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage")))
563
564(setup-lookup-calls)
565
566;;;
567;;; given an entry address (a number) and a symbol name (lisp string)
568;;; find the associated dylib or module
569;;; if the dylib or module is not found in *shared-libraries* list it is added
570;;; if not found in the OS list it returns nil
571;;;
572;;; got this error before putting in the call to
573;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead
574;;; lock (dyld operation attempted in a thread already doing a dyld
575;;; operation)
576;;;
577
578(defun legacy-shlib-containing-address (addr name)
579  (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword))
580    (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address)))
581      (when (and (not (%null-ptr-p header))
582                 (or (eql (pref header :mach_header.filetype) #$MH_DYLIB)
583                     (eql (pref header :mach_header.filetype) #$MH_BUNDLE)))
584        ;; make sure the image is either a bundle or a dylib
585        ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5)
586        (with-cstrs ((cname name))
587          ;; also we must check is symbol name is defined in the
588          ;; image otherwise in certain cases there is a crash,
589          ;; another likely OS bug happens in the case where a
590          ;; bundle imports a dylib and then we call
591          ;; nslookupsymbolinimage on the bundle image
592          (when (/= 0
593                    (ff-call *ns-is-symbol-name-defined-in-image* :address header
594                             :address cname :unsigned))
595            (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname
596                                   :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR
597                                   :address)))
598              (unless (%null-ptr-p symbol)
599                ;; compare the found address to the address we are looking for
600                (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address)))
601                  ;; (format t "Foundaddr ~s~%" foundaddr)
602                  ;; (format t "Compare to addr ~s~%" addr)
603                  (when (eql foundaddr addr)
604                    (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
605                           (libname (unless (%null-ptr-p imgname) (%get-cstring imgname)))
606                           (libmodule (%int-to-ptr 0))
607                           (libheader (%int-to-ptr 0)))
608                      (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE)
609                        (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address))
610                        (setf libheader header))
611                      ;; make sure that this shared library is on *shared-libraries*
612                      (return (shared-library-from-header-module-or-name libheader libmodule libname)))))))))))))
613
614(defun shlib-containing-address (address name)
615  (if (zerop *dladdr-entry*)
616    (legacy-shlib-containing-address address name)
617    ;; Bootstrapping.  RLET might be clearer here.
618    (%stack-block ((info (record-length #>Dl_info) :clear t))
619      (unless (zerop (ff-call *dladdr-entry*
620                              :address address
621                              :address info
622                              :signed-fullword))
623        (let* ((addr (pref info #>Dl_info.dli_fbase)))
624          (format t "~&name = ~s" (pref info  #>Dl_info.dli_fname))
625         
626          (dolist (lib *shared-libraries*)
627            (when (eql (shlib.base lib) addr)
628              (return lib))))))))
629
630(defun shlib-containing-entry (entry &optional name)
631  (unless name
632    (error "foreign name must be non-NIL."))
633  (with-macptrs (addr)
634    (entry->addr entry addr)
635    (shlib-containing-address addr name)))
636
637;; end Darwin progn
638)
639
640#-(or linux-target darwin-target freebsd-target solaris-target)
641(defun shlib-containing-entry (entry &optional name)
642  (declare (ignore entry name))
643  *rtld-default*)
644
645
646(defun resolve-eep (e &optional (require-resolution t))
647  (or (eep.address e)
648      (let* ((name (eep.name e))
649             (container (eep.container e))
650             (handle (resolve-container container require-resolution))
651             (addr (foreign-symbol-entry name handle)))
652        (if addr
653          (progn
654            (unless container
655              (setf (eep.container e) (shlib-containing-entry addr name)))
656            (setf (eep.address e) addr))
657          (if require-resolution
658            (error "Can't resolve foreign symbol ~s" name))))))
659
660
661
662(defun foreign-symbol-address (name &optional (map *rtld-next*))
663  "Try to resolve the address of the foreign symbol name. If successful,
664return that address encapsulated in a MACPTR, else returns NIL."
665  (with-cstrs ((n name))
666    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address)))
667      (unless (%null-ptr-p addr)
668        addr))))
669
670(defun resolve-foreign-variable (fv &optional (require-resolution t))
671  (or (fv.addr fv)
672      (let* ((name (fv.name fv))
673             (container (fv.container fv))
674             (handle (resolve-container container require-resolution))
675             (addr (foreign-symbol-address name handle)))
676        (if addr
677          (progn
678            (unless container
679              (setf (fv.container fv) (shlib-containing-address addr name)))
680            (setf (fv.addr fv) addr))
681          (if require-resolution
682            (error "Can't resolve foreign symbol ~s" name))))))
683
684(defun load-eep (name)
685  (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name)))))
686    (resolve-eep eep nil)
687    eep))
688
689
690
691(defun load-fv (name type)
692  (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type)))))
693    (resolve-foreign-variable fv nil)
694    fv))
695
696         
697
698
699
700
701#+(or linux-target freebsd-target solaris-target)
702(progn
703;;; It's assumed that the set of libraries that the OS has open
704;;; (accessible via the _dl_loaded global variable) is a subset of
705;;; the libraries on *shared-libraries*.
706
707(defun revive-shared-libraries ()
708  (dolist (lib *shared-libraries*)
709    (setf (shlib.map lib) nil
710          (shlib.pathname lib) nil
711          (shlib.base lib) nil)
712    (let* ((soname (shlib.soname lib)))
713      (when soname
714        (with-cstrs ((soname soname))
715          (let* ((map (block found
716                        (%walk-shared-libraries
717                         #'(lambda (m)
718                             (with-macptrs (libname)
719                               (%setf-macptr libname
720                                             (soname-ptr-from-link-map m))
721                               (unless (%null-ptr-p libname)
722                                 (when (%cstrcmp soname libname)
723                                   (return-from found  m)))))))))
724            (when map
725              ;;; Sigh.  We can't reliably lookup symbols in the library
726              ;;; unless we open the library (which is, of course,
727              ;;; already open ...)  ourselves, passing in the
728              ;;; #$RTLD_GLOBAL flag.
729              #+linux-target
730              (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
731                       :address soname
732                       :unsigned-fullword *dlopen-flags*
733                       :void)
734              (setf (shlib.base lib) (%int-to-ptr (pref map :link_map.l_addr))
735                    (shlib.pathname lib) (%get-cstring
736                                          (pref map :link_map.l_name))
737                    (shlib.map lib) map))))))))
738
739;;; Repeatedly iterate over shared libraries, trying to open those
740;;; that weren't already opened by the kernel.  Keep doing this until
741;;; we reach stasis (no failures or no successes.)
742
743(defun %reopen-user-libraries ()
744  (loop
745      (let* ((win nil)
746             (lose nil))
747        (dolist (lib *shared-libraries*)
748          (let* ((map (shlib.map lib))
749                 (handle (shlib.handle lib)))
750            (unless map
751              (with-cstrs ((soname (shlib.soname lib)))
752                (setq handle
753                      (ff-call
754                       (%kernel-import target::kernel-import-GetSharedLibrary)
755                       :address soname
756                       :unsigned-fullword *dlopen-flags*
757                       :address))
758                #-(or freebsd-target solaris-target) (setq map handle)
759                #+(or freebsd-target solaris-target)
760                (setq map
761                      (if (%null-ptr-p handle)
762                        handle
763                        (rlet ((p :address))
764                          (if (eql 0 (ff-call
765                                      (foreign-symbol-entry "dlinfo")
766                                      :address handle
767                                      :int #$RTLD_DI_LINKMAP
768                                      :address p
769                                      :int))
770                            (pref p :address)
771                            (%null-ptr)))))
772                (if (%null-ptr-p map)
773                  (setq lose t)
774                  (setf (shlib.pathname lib)
775                        (%get-cstring (pref map :link_map.l_name))
776                        (shlib.base lib)
777                        (%int-to-ptr (pref map :link_map.l_addr))
778                        (shlib.map lib) map
779                        (shlib.handle lib) handle
780                        win t))))))
781        (when (or (not lose) (not win)) (return)))))
782)
783
784
785(defun refresh-external-entrypoints ()
786  #+linux-target
787  (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked))))
788  (%revive-macptr *rtld-next*)
789  (%revive-macptr *rtld-default*)
790  #+(or linux-target freebsd-target solaris-target)
791  (unless *statically-linked*
792    (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
793    (revive-shared-libraries)
794    (%reopen-user-libraries))
795  #+darwin-target
796  (progn
797    (setup-lookup-calls)
798    (reopen-user-libraries))
799  (when *eeps*
800    (without-interrupts 
801     (maphash #'(lambda (k v) 
802                  (declare (ignore k)) 
803                  (setf (eep.address v) nil) 
804                  (resolve-eep v nil))
805              *eeps*)))
806  (when *fvs*
807    (without-interrupts
808     (maphash #'(lambda (k v)
809                  (declare (ignore k))
810                  (setf (fv.addr v) nil)
811                  (resolve-foreign-variable v nil))
812              *fvs*))))
813
814
Note: See TracBrowser for help on using the repository browser.