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

Last change on this file since 9917 was 9917, checked in by gz, 13 years ago

Move more definitions into lispequ. To bootstrap, (load "ccl:library;lispequ.lisp") before recompiling

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