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

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

propagate changes from working-0711-perf branch

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