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

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

In the extremely troublesome SONAME-PTR-FROM-LINK-MAP: dynamic entries
may be in the high end of the address space, so be careful about signedness.
There were/are issues with Linux's use of the Elf*_Dyn_D_un union: sometimes
(when a vdso is involved) the DT_STRTAB is a signed displacement relative
to to the link map's l_addr value, most other times its an absolute address,
(The ELF spec that I've seen says that it should always be an absolute
address; both FreeBSD and Solaris seem to always set it to a relative
offset.) If, when interpreted as an address, it's between the l_addr of
the map and the dynamic entry, treat it as an address, otherwise, fall
back on the older heuristic based on the apparent sign.

I don't like any of this (guessing), but this seems to allow the shared
lib init stuff to work on the 2.6.24 sytem that I have access to and
hopefully closes ticket:338.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 34.8 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#+windows-target
23(progn
24  (defvar *windows-invalid-handle* nil)
25  (setq *windows-invalid-handle* (%int-to-ptr #+64-bit-target #xffffffffffffffff #+32-bit-target #xffffffff)))
26
27
28;;; We have several different conventions for representing an
29;;; "entry" (a foreign symbol address, possibly represented as
30;;; something cheaper than a MACPTR.)  Destructively modify
31;;; ADDR so that it points to where ENTRY points.
32(defun entry->addr (entry addr)
33  #+ppc32-target
34  ;; On PPC32, all function addresses have their low 2 bits clear;
35  ;; so do fixnums.
36  (%setf-macptr-to-object addr entry)
37  #+ppc64-target
38  ;; On PPC64, some addresses can use the fixnum trick.  In other
39  ;; cases, an "entry" is just a MACPTR.
40  (if (typep entry 'fixnum)
41    (%setf-macptr-to-object addr entry)
42    (%setf-macptr addr entry))
43  ;; On x86, an "entry" is just an integer.  There might elswehere be
44  ;; some advantage in treating those integers as signed (they might
45  ;; be more likely to be fixnums, for instance), so ensure that they
46  ;; aren't.
47  #+x86-target
48  (%setf-macptr addr (%int-to-ptr
49                      (if (< entry 0)
50                        (logand entry (1- (ash 1 target::nbits-in-word)))
51                        entry)))
52  #-(or ppc-target x86-target) (dbg "Fix entry->addr"))
53
54
55
56
57;;; Bootstrapping. Real version is in l1-aprims.
58;;; Called by expansion of with-pstrs
59
60(defun byte-length (string &optional script start end)
61    (declare (ignore script))
62    (when (or start end)
63      (error "Don't support start or end args yet"))
64    (if (base-string-p string)
65      (length string)
66      (error "Don't support non base-string yet.")))
67
68
69
70
71(defun external-entry-point-p (x)
72  (istruct-typep x 'external-entry-point))
73
74;;; On both Linux and FreeBSD, RTLD_NEXT and RTLD_DEFAULT behave
75;;; the same way wrt symbols defined somewhere other than the lisp
76;;; kernel.  On Solaris, RTLD_DEFAULT will return the address of
77;;; an imported symbol's procedure linkage table entry if the symbol
78;;; has a plt entry (e.g., if it happens to be referenced by the
79;;; lisp kernel.)  *RTLD-NEXT* is therefore a slightly better
80;;; default; we've traditionaly used *RTLD-DEFAULT*.
81(defvar *rtld-next*)
82(defvar *rtld-default*)
83(setq *rtld-next* (%incf-ptr (%null-ptr) -1)
84      *rtld-default* (%int-to-ptr #+(or linux-target darwin-target windows-target)  0
85                                  #-(or linux-target darwin-target windows-target)  -2))
86
87#+(or linux-target freebsd-target solaris-target)
88(progn
89
90(defvar *dladdr-entry*)
91 
92;;; I can't think of a reason to change this.
93(defvar *dlopen-flags* nil)
94(setq *dlopen-flags* (logior #$RTLD_GLOBAL #$RTLD_NOW))
95)
96
97(defvar *eeps* nil)
98
99(defvar *fvs* nil)
100
101(defun eeps ()
102  (or *eeps*
103      (setq *eeps* (make-hash-table :test #'equal))))
104
105(defun fvs ()
106  (or *fvs*
107      (setq *fvs* (make-hash-table :test #'equal))))
108
109(defun unload-foreign-variables (lib)
110  (let* ((fvs (fvs)))
111    (when fvs
112      (maphash #'(lambda (k fv)
113                   (declare (ignore k))
114                   (when (eq (fv.container fv) lib)
115                     (setf (fv.addr fv) nil)))
116               fvs))))
117
118(defun generate-external-functions (path)
119  (let* ((names ()))
120    (maphash #'(lambda (k ignore)
121                 (declare (ignore ignore))
122                 (push k names)) (eeps))
123    (with-open-file (stream path
124                            :direction :output
125                            :if-exists :supersede
126                            :if-does-not-exist :create)
127      (dolist (k names) (format stream "~&extern void * ~a();" k))
128     
129      (format stream "~&external_function external_functions[] = {")
130      (dolist (k names) (format stream "~&~t{~s,~a}," k k))
131      (format stream "~&~t{0,0}~&};"))))
132
133   
134(defvar *shared-libraries* nil)
135
136#+(or linux-target freebsd-target solaris-target)
137(progn
138
139(defun soname-ptr-from-link-map (map)
140  (with-macptrs ((dyn-strings)
141                 (dynamic-entries (pref map :link_map.l_ld)))
142    (let* ((soname-offset nil))
143      ;; Walk over the entries in the file's dynamic segment; the
144      ;; last such entry will have a tag of #$DT_NULL.  Note the
145      ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD)
146      ;; address of the dynamic string table and the offset of the
147      ;; #$DT_SONAME string in that string table.
148      ;; Actually, the above isn't quite right; there seem to
149      ;; be cases (involving vDSO) where the address of a library's
150      ;; dynamic string table is expressed as an offset relative
151      ;; to link_map.l_addr as well.
152      (loop
153          (case #+32-bit-target (pref dynamic-entries :<E>lf32_<D>yn.d_tag)
154                #+64-bit-target (pref dynamic-entries :<E>lf64_<D>yn.d_tag)
155            (#. #$DT_NULL (return))
156            (#. #$DT_SONAME
157                (setq soname-offset
158                      #+32-bit-target (pref dynamic-entries
159                                           :<E>lf32_<D>yn.d_un.d_val)
160                      #+64-bit-target (pref dynamic-entries
161                                           :<E>lf64_<D>yn.d_un.d_val)))
162            (#. #$DT_STRTAB
163                (%setf-macptr dyn-strings
164                              ;; Try to guess whether we're dealing
165                              ;; with a displacement or with an
166                              ;; absolute address.  There may be
167                              ;; a better way to determine this,
168                              ;; but for now we assume that absolute
169                              ;; addresses aren't negative and that
170                              ;; displacements are.
171                               (let* ((disp (%get-signed-natural
172                                             dynamic-entries
173                                             target::node-size)))
174                                 #+(or freebsd-target solaris-target)
175                                 (%inc-ptr (pref map :link_map.l_addr) disp)
176                                 #-(or freebsd-target solaris-target)
177                                 (let* ((udisp #+32-bit-target (pref dynamic-entries
178                                                                     :<E>lf32_<D>yn.d_un.d_val)
179                                               #+64-bit-target (pref dynamic-entries
180                                                                     :<E>lf64_<D>yn.d_un.d_val)))
181                                   (if (and (> udisp (pref map :link_map.l_addr))
182                                            (< udisp (%ptr-to-int dynamic-entries)))
183                                     (%int-to-ptr udisp)
184                                     (%int-to-ptr 
185                                      (if (< disp 0) 
186                                        (+ disp (pref map :link_map.l_addr))
187                                        disp))))))))
188          (%setf-macptr dynamic-entries
189                        (%inc-ptr dynamic-entries
190                                  #+32-bit-target
191                                  (record-length :<E>lf32_<D>yn)
192                                  #+64-bit-target
193                                  (record-length :<E>lf64_<D>yn))))
194      (if (and soname-offset
195               (not (%null-ptr-p dyn-strings)))
196        (%inc-ptr dyn-strings soname-offset)
197        ;; Use the full pathname of the library.
198        (pref map :link_map.l_name)))))
199
200(defun shared-library-at (base)
201  (dolist (lib *shared-libraries*)
202    (when (eql (shlib.base lib) base)
203      (return lib))))
204
205(defun shared-library-with-name (name)
206  (let* ((namelen (length name)))
207    (dolist (lib *shared-libraries*)
208      (let* ((libname (shlib.soname lib)))
209        (when (%simple-string= name libname 0 0 namelen (length libname))
210          (return lib))))))
211
212(defun shlib-from-map-entry (m)
213  (let* ((base (%int-to-ptr (pref m :link_map.l_addr))))
214    ;; On relatively modern Linux systems, this is often NULL.
215    ;; I'm not sure what (SELinux ?  Pre-binding ?  Something else ?)
216    ;; counts as being "relatively modern" in this case.
217    ;; The link-map's l_ld field is a pointer to the .so's dynamic
218    ;; section, and #_dladdr seems to recognize that as being an
219    ;; address within the library and returns a reasonable "base address".
220    (when (%null-ptr-p base)
221      (let* ((addr (%library-base-containing-address (pref m :link_map.l_ld))))
222        (if addr (setq base addr))))
223    (or (let* ((existing-lib (shared-library-at base)))
224          (when (and existing-lib (null (shlib.map existing-lib)))
225            (setf (shlib.map existing-lib) m
226                  (shlib.pathname existing-lib)
227                  (%get-cstring (pref m :link_map.l_name))
228                  (shlib.base existing-lib) base))
229          existing-lib)
230        (let* ((soname-ptr (soname-ptr-from-link-map m))
231               (soname (unless (%null-ptr-p soname-ptr) (%get-cstring soname-ptr)))
232               (pathname (%get-cstring (pref m :link_map.l_name)))
233               (shlib (shared-library-with-name soname)))
234          (if shlib
235            (setf (shlib.map shlib) m
236                  (shlib.base shlib) base
237                  (shlib.pathname shlib) pathname)
238            (push (setq shlib (%cons-shlib soname pathname m base))
239                  *shared-libraries*))
240          shlib))))
241
242
243(defun %get-r-debug ()
244  (let* ((addr (ff-call (%kernel-import target::kernel-import-get-r-debug)
245                        address)))
246    (unless (%null-ptr-p addr)
247      addr)))
248
249(defun %link-map-address ()
250  (let* ((r_debug (%get-r-debug)))
251    (if r_debug
252      (pref r_debug :r_debug.r_map)
253      (let* ((p (or (foreign-symbol-address "_dl_loaded")
254                    (foreign-symbol-address "_rtld_global"))))
255        (if p
256          (%get-ptr p))))))
257
258(defun %walk-shared-libraries (f)
259  (let* ((loaded (%link-map-address)))
260    (do* ((map (pref loaded :link_map.l_next) (pref map :link_map.l_next)))
261         ((%null-ptr-p map))
262      (funcall f map))))
263
264
265(defun %dlopen-shlib (l)
266  (with-cstrs ((n (shlib.soname l)))
267    (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
268             :address n
269             :unsigned-fullword *dlopen-flags*
270             :void)))
271 
272(defun init-shared-libraries ()
273  (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
274  (when (null *shared-libraries*)
275    (%walk-shared-libraries #'shlib-from-map-entry)
276      ;;; On Linux, it seems to be necessary to open each of these
277      ;;; libraries yet again, specifying the RTLD_GLOBAL flag.
278      ;;; On FreeBSD, it seems desirable -not- to do that.
279    #+linux-target
280    (dolist (l *shared-libraries*)
281      (%dlopen-shlib l))))
282
283(init-shared-libraries)
284
285;;; Walk over all registered entrypoints, invalidating any whose container
286;;; is the specified library.  Return true if any such entrypoints were
287;;; found.
288(defun unload-library-entrypoints (lib)
289  (let* ((count 0))
290    (declare (fixnum count))
291    (maphash #'(lambda (k eep)
292                 (declare (ignore k))
293                 (when (eq (eep.container eep) lib)
294                   (setf (eep.address eep) nil)
295                   (incf count)))
296             (eeps))   
297    (not (zerop count))))
298
299
300                     
301                     
302
303(defun open-shared-library (name)
304  "If the library denoted by name can be loaded by the operating system,
305return an object of type SHLIB that describes the library; if the library
306is already open, increment a reference count. If the library can't be
307loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
308the operating system."
309  (let* ((handle (with-cstrs ((name name))
310                        (ff-call
311                         (%kernel-import target::kernel-import-GetSharedLibrary)
312                         :address name
313                         :unsigned-fullword *dlopen-flags*
314                         :address)))
315         (link-map #-(or freebsd-target solaris-target) handle
316                   #+(or freebsd-target solaris-target)
317                   (if (%null-ptr-p handle)
318                     handle
319                     (rlet ((p :address))
320                       (if (eql 0 (ff-call
321                                   (foreign-symbol-entry "dlinfo")
322                                   :address handle
323                                   :int #$RTLD_DI_LINKMAP
324                                   :address p
325                                   :int))
326                         (pref p :address)
327                         (%null-ptr))))))
328    (if (%null-ptr-p link-map)
329      (error "Error opening shared library ~s: ~a" name (dlerror))
330      (prog1 (let* ((lib (shlib-from-map-entry link-map)))
331               (incf (shlib.opencount lib))
332               (setf (shlib.handle lib) handle)
333               lib)
334        (%walk-shared-libraries
335         #'(lambda (map)
336             (unless (shared-library-at
337                      (%int-to-ptr (pref map :link_map.l_addr)))
338               (let* ((new (shlib-from-map-entry map)))
339                 (%dlopen-shlib new)))))))))
340
341)
342
343
344#+darwin-target
345(progn
346
347(defun shared-library-with-header (header)
348  (dolist (lib *shared-libraries*)
349    (when (eql (shlib.map lib) header)
350      (return lib))))
351
352(defun shared-library-with-module (module)
353  (dolist (lib *shared-libraries*)
354    (when (eql (shlib.base lib) module)
355      (return lib))))
356
357(defun shared-library-with-name (name &optional (is-unloaded nil))
358  (let* ((namelen (length name)))
359    (dolist (lib *shared-libraries*)
360      (let* ((libname (shlib.soname lib)))
361        (when (and (%simple-string= name libname 0 0 namelen (length libname))
362                   (or (not is-unloaded) (and (null (shlib.map lib))
363                                              (null (shlib.base lib)))))
364          (return lib))))))
365
366;;;   
367;;; maybe we could fix this up name to get the "real name"
368;;; this is might be possible for dylibs but probably not for modules
369;;; for now soname and pathname are just the name that the user passed in
370;;; if the library is "discovered" later, it is the name the system gave
371;;; to it -- usually a full pathname
372;;;
373;;; header and module are ptr types
374;;;
375(defun shared-library-from-header-module-or-name (header module name)
376  ;; first try to find the library based on its address
377  (let ((found-lib (if (%null-ptr-p module)
378                       (shared-library-with-header header)
379                     (shared-library-with-module module))))
380   
381    (unless found-lib
382      ;; check if the library name is still on our list but has been unloaded
383      (setq found-lib (shared-library-with-name name t))
384      (if found-lib
385        (setf (shlib.map found-lib) header
386              (shlib.base found-lib) module)
387        ;; otherwise add it to the list
388        (push (setq found-lib (%cons-shlib name name header module))
389              *shared-libraries*)))
390    found-lib))
391
392
393(defun open-shared-library (name)
394  "If the library denoted by name can be loaded by the operating system,
395return an object of type SHLIB that describes the library; if the library
396is already open, increment a reference count. If the library can't be
397loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
398the operating system."
399  (rlet ((type :signed))
400    (let ((result (with-cstrs ((cname name))
401                    (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
402                             :address cname
403                             :address type
404                             :address))))
405        (cond
406         ((= 1 (pref type :signed))
407          ;; dylib
408          (shared-library-from-header-module-or-name result (%null-ptr) name))
409         ((= 2 (pref type :signed))
410          ;; bundle
411          (shared-library-from-header-module-or-name (%null-ptr) result name))
412         ((= 0 (pref type :signed))
413          ;; neither a dylib nor bundle was found
414          (error "Error opening shared library ~s: ~a" name
415                 (%get-cstring result)))
416         (t (error "Unknown error opening shared library ~s." name))))))
417
418;;; Walk over all registered entrypoints, invalidating any whose container
419;;; is the specified library.  Return true if any such entrypoints were
420;;; found.
421;;;
422;;; SAME AS LINUX VERSION
423;;;
424(defun unload-library-entrypoints (lib)
425  (let* ((count 0))
426    (declare (fixnum count))
427    (maphash #'(lambda (k eep)
428                 (declare (ignore k))
429                 (when (eq (eep.container eep) lib)
430                   (setf (eep.address eep) nil)
431                   (incf count)))
432             (eeps))   
433    (not (zerop count))))
434
435;;;
436;;; When restarting from a saved image
437;;;
438(defun reopen-user-libraries ()
439  (dolist (lib *shared-libraries*)
440    (setf (shlib.map lib) nil
441          (shlib.base lib) nil))
442  (loop
443      (let* ((win nil)
444             (lose nil))
445        (dolist (lib *shared-libraries*)
446          (let* ((header (shlib.map lib))
447                 (module (shlib.base lib)))
448            (unless (and header module)
449              (rlet ((type :signed))
450                (let ((result (with-cstrs ((cname (shlib.soname lib)))
451                                (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
452                                         :address cname
453                                         :address type
454                                         :address))))
455                  (cond
456                   ((= 1 (pref type :signed))
457                    ;; dylib
458                    (setf (shlib.map lib) result
459                          (shlib.base lib) (%null-ptr)
460                          win t))
461                   ((= 2 (pref type :signed))
462                    ;; bundle
463                    (setf (shlib.map lib) (%null-ptr)
464                          (shlib.base lib) result
465                          win t))
466                   (t
467                    ;; neither a dylib nor bundle was found
468                    (setq lose t))))))))
469        (when (or (not lose) (not win)) (return)))))
470
471;;; end darwin-target
472  ) 
473
474#+windows-target
475(progn
476  (defvar *current-process-handle*)
477  (defvar *enum-process-modules-addr*)
478  (defvar *get-module-file-name-addr*)
479  (defvar *get-module-base-name-addr*)
480  (defvar *get-module-handle-ex-addr*)
481
482
483  (defun init-windows-ffi ()
484    (%revive-macptr *windows-invalid-handle*)
485    (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address)) 
486    (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules"))   
487    (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA"))
488    (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA"))
489    (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA")))
490
491  (init-windows-ffi)
492 
493  (defun hmodule-pathname (hmodule)
494    (do* ((bufsize 64))
495         ()
496      (%stack-block ((name bufsize))
497        (let* ((needed (ff-call *get-module-file-name-addr*
498                                :address *current-process-handle*
499                                :address hmodule
500                                :address name
501                                :signed-fullword bufsize
502                                :signed-fullword)))
503          (if (eql 0 needed)
504            (return nil)
505            (if (< bufsize needed)
506              (setq bufsize needed)
507              (return (%str-from-ptr name needed))))))))
508
509  (defun hmodule-basename (hmodule)
510    (do* ((bufsize 64))
511         ()
512      (%stack-block ((name bufsize))
513        (let* ((needed (ff-call *get-module-base-name-addr*
514                                :address *current-process-handle*
515                                :address hmodule
516                                :address name
517                                :signed-fullword bufsize
518                                :signed-fullword)))
519          (if (eql 0 needed)
520            (return nil)
521            (if (< bufsize needed)
522              (setq bufsize needed)
523              (return (%str-from-ptr name needed))))))))
524
525  (defun existing-shlib-for-hmodule (hmodule)
526    (dolist (shlib *shared-libraries*)
527      (when (eql hmodule (shlib.map shlib)) (return shlib))))
528     
529 
530  (defun shared-library-from-hmodule (hmodule)
531    (or (existing-shlib-for-hmodule hmodule)
532        (let* ((shlib (%cons-shlib (hmodule-basename hmodule)
533                                   (hmodule-pathname hmodule)
534                                   hmodule
535                                   hmodule)))
536          (push shlib *shared-libraries*)
537          shlib)))
538
539  (defun for-each-loaded-module (f)
540    (let* ((have (* 16 (record-length #>HMODULE))))
541      (rlet ((pneed #>DWORD))
542        (loop
543          (%stack-block ((modules have))
544            (ff-call *enum-process-modules-addr*
545                     :address *current-process-handle*
546                     :address modules
547                     #>DWORD have
548                     :address pneed)
549            (let* ((need (pref pneed #>DWORD)))
550              (if (> need have)
551                (setq have need)
552                (return
553                  (do* ((i 0 (+ i (record-length #>HMODULE))))
554                       ((= i need))
555                    (funcall f (%get-ptr modules i)))))))))))
556
557  (defun init-shared-libraries ()
558    (for-each-loaded-module #'shared-library-from-hmodule))
559 
560  (defun shlib-containing-entry (addr &optional name)
561    (with-macptrs ((p (%int-to-ptr addr)))
562      (shlib-containing-address p name)))
563
564  (defun shlib-containing-address (addr &optional name)
565    (declare (ignore name))
566    (rlet ((phmodule :address +null-ptr+))
567      (let* ((found (ff-call *get-module-handle-ex-addr*
568                             #>DWORD (logior
569                                      #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
570                                      #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT)
571                             :address addr
572                             :address phmodule
573                             #>BOOL)))
574        (unless (eql 0 found)
575          (let* ((hmodule (pref phmodule :address)))
576            (dolist (lib *shared-libraries*)
577              (when (eql (shlib.map lib)  hmodule)
578                (return lib))))))))
579
580
581  (defun open-shared-library (name)
582    "If the library denoted by name can be loaded by the operating system,
583return an object of type SHLIB that describes the library; if the library
584is already open, increment a reference count. If the library can't be
585loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
586the operating system."
587    (let* ((hmodule (with-cstrs ((name name))
588                      (ff-call
589                       (%kernel-import target::kernel-import-GetSharedLibrary)
590                       :address name
591                       :unsigned-fullword 0
592                       :address)))
593           (shlib (unless (%null-ptr-p hmodule)
594                    (shared-library-from-hmodule hmodule))))
595      (if shlib
596        (progn
597          (incf (shlib.opencount shlib))
598          (setf (shlib.handle shlib) hmodule)
599          shlib)
600        (error "Can't open shared library ~s" name))))
601
602(init-shared-libraries)
603
604;;; end windows-target
605) 
606
607
608(defun ensure-open-shlib (c force)
609  (if (or (shlib.map c) (not force))
610    *rtld-next*
611    (error "Shared library not open: ~s" (shlib.soname c))))
612
613(defun resolve-container (c force)
614  (if c
615    (ensure-open-shlib c force)
616    *rtld-next*
617    ))
618
619
620
621
622;;; An "entry" can be fixnum (the low 2 bits are clear) which represents
623;;; a (32-bit word)-aligned address.  That convention covers all
624;;; function addresses on ppc32 and works for addresses that are
625;;; 0 mod 8 on PPC64, but can't work for things that're byte-aligned
626;;; (x8664 and other non-RISC platforms.)
627;;; For PPC64, we may have to cons up a macptr if people use broken
628;;; linkers.  (There are usually cache advantages to aligning ppc
629;;; function addresses on at least a 16-byte boundary, but some
630;;; linkers don't quite get the concept ...)
631
632(defun foreign-symbol-entry (name &optional (handle *rtld-next*))
633  "Try to resolve the address of the foreign symbol name. If successful,
634return a fixnum representation of that address, else return NIL."
635  (with-cstrs ((n name))
636    #+ppc-target
637    (with-macptrs (addr)     
638      (%setf-macptr addr
639                    (ff-call (%kernel-import target::kernel-import-FindSymbol)
640                             :address handle
641                             :address n
642                             :address))
643      (unless (%null-ptr-p addr)        ; No function can have address 0
644        (or (macptr->fixnum addr) (%inc-ptr addr 0))))
645    #+x8632-target
646    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
647                          :address handle
648                          :address n
649                          :unsigned-fullword)))
650      (unless (eql 0 addr) addr))
651    #+x8664-target
652    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
653                          :address handle
654                          :address n
655                          :unsigned-doubleword)))
656      (unless (eql 0 addr) addr))))
657
658(defvar *statically-linked* nil)
659
660#+(or linux-target freebsd-target solaris-target)
661(progn
662
663(defun %library-base-containing-address (address)
664  (rletZ ((info :<D>l_info))
665    (let* ((status (ff-call *dladdr-entry*
666                            :address address
667                            :address info :signed-fullword)))
668      (declare (integer status))
669      (unless (zerop status)
670        (pref info :<D>l_info.dli_fbase)))))
671 
672(defun shlib-containing-address (address &optional name)
673  (declare (ignore name))
674  (let* ((base (%library-base-containing-address address)))
675    (if base
676      (shared-library-at base))))
677
678
679(defun shlib-containing-entry (entry &optional name)
680  (unless *statically-linked*
681    (with-macptrs (p)
682      (entry->addr entry p)
683      (shlib-containing-address p name))))
684)
685
686#+darwin-target
687(progn
688(defvar *dyld-image-count*)
689(defvar *dyld-get-image-header*)
690(defvar *dyld-get-image-name*)
691(defvar *nslookup-symbol-in-image*)
692(defvar *nsaddress-of-symbol*)
693(defvar *nsmodule-for-symbol*)
694(defvar *ns-is-symbol-name-defined-in-image*)
695(defvar *dladdr-entry* 0)
696
697(defun setup-lookup-calls ()
698  #+notyet
699  (setq *dladdr-entry* (foreign-symbol-entry "_dladdr"))
700  (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count"))
701  (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header"))
702  (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name"))
703  (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage"))
704  (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol"))
705  (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol"))
706  (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage")))
707
708(setup-lookup-calls)
709
710;;;
711;;; given an entry address (a number) and a symbol name (lisp string)
712;;; find the associated dylib or module
713;;; if the dylib or module is not found in *shared-libraries* list it is added
714;;; if not found in the OS list it returns nil
715;;;
716;;; got this error before putting in the call to
717;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead
718;;; lock (dyld operation attempted in a thread already doing a dyld
719;;; operation)
720;;;
721
722(defun legacy-shlib-containing-address (addr name)
723  (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword))
724    (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address)))
725      (when (and (not (%null-ptr-p header))
726                 (or (eql (pref header :mach_header.filetype) #$MH_DYLIB)
727                     (eql (pref header :mach_header.filetype) #$MH_BUNDLE)))
728        ;; make sure the image is either a bundle or a dylib
729        ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5)
730        (with-cstrs ((cname name))
731          ;; also we must check is symbol name is defined in the
732          ;; image otherwise in certain cases there is a crash,
733          ;; another likely OS bug happens in the case where a
734          ;; bundle imports a dylib and then we call
735          ;; nslookupsymbolinimage on the bundle image
736          (when (/= 0
737                    (ff-call *ns-is-symbol-name-defined-in-image* :address header
738                             :address cname :unsigned))
739            (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname
740                                   :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR
741                                   :address)))
742              (unless (%null-ptr-p symbol)
743                ;; compare the found address to the address we are looking for
744                (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address)))
745                  ;; (format t "Foundaddr ~s~%" foundaddr)
746                  ;; (format t "Compare to addr ~s~%" addr)
747                  (when (eql foundaddr addr)
748                    (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
749                           (libname (unless (%null-ptr-p imgname) (%get-cstring imgname)))
750                           (libmodule (%int-to-ptr 0))
751                           (libheader (%int-to-ptr 0)))
752                      (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE)
753                        (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address))
754                        (setf libheader header))
755                      ;; make sure that this shared library is on *shared-libraries*
756                      (return (shared-library-from-header-module-or-name libheader libmodule libname)))))))))))))
757
758(defun shlib-containing-address (address name)
759  (if (zerop *dladdr-entry*)
760    (legacy-shlib-containing-address address name)
761    ;; Bootstrapping.  RLET might be clearer here.
762    (%stack-block ((info (record-length #>Dl_info) :clear t))
763      (unless (zerop (ff-call *dladdr-entry*
764                              :address address
765                              :address info
766                              :signed-fullword))
767        (let* ((addr (pref info #>Dl_info.dli_fbase)))
768          (format t "~&name = ~s" (pref info  #>Dl_info.dli_fname))
769         
770          (dolist (lib *shared-libraries*)
771            (when (eql (shlib.base lib) addr)
772              (return lib))))))))
773
774(defun shlib-containing-entry (entry &optional name)
775  (unless name
776    (error "foreign name must be non-NIL."))
777  (with-macptrs (addr)
778    (entry->addr entry addr)
779    (shlib-containing-address addr name)))
780
781;; end Darwin progn
782)
783
784#-(or linux-target darwin-target freebsd-target solaris-target windows-target)
785(defun shlib-containing-entry (entry &optional name)
786  (declare (ignore entry name))
787  *rtld-default*)
788
789
790(defun resolve-eep (e &optional (require-resolution t))
791  (or (eep.address e)
792      (let* ((name (eep.name e))
793             (container (eep.container e))
794             (handle (resolve-container container require-resolution))
795             (addr (foreign-symbol-entry name handle)))
796        (if addr
797          (progn
798            (unless container
799              (setf (eep.container e) (shlib-containing-entry addr name)))
800            (setf (eep.address e) addr))
801          (if require-resolution
802            (error "Can't resolve foreign symbol ~s" name))))))
803
804
805
806(defun foreign-symbol-address (name &optional (map *rtld-next*))
807  "Try to resolve the address of the foreign symbol name. If successful,
808return that address encapsulated in a MACPTR, else returns NIL."
809  (with-cstrs ((n name))
810    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address)))
811      (unless (%null-ptr-p addr)
812        addr))))
813
814(defun resolve-foreign-variable (fv &optional (require-resolution t))
815  (or (fv.addr fv)
816      (let* ((name (fv.name fv))
817             (container (fv.container fv))
818             (handle (resolve-container container require-resolution))
819             (addr (foreign-symbol-address name handle)))
820        (if addr
821          (progn
822            (unless container
823              (setf (fv.container fv) (shlib-containing-address addr name)))
824            (setf (fv.addr fv) addr))
825          (if require-resolution
826            (error "Can't resolve foreign symbol ~s" name))))))
827
828(defun load-eep (name)
829  (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name)))))
830    (resolve-eep eep nil)
831    eep))
832
833(defun load-fv (name type)
834  (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type)))))
835    (resolve-foreign-variable fv nil)
836    fv))
837
838         
839
840
841
842
843#+(or linux-target freebsd-target solaris-target)
844(progn
845;;; It's assumed that the set of libraries that the OS has open
846;;; (accessible via the _dl_loaded global variable) is a subset of
847;;; the libraries on *shared-libraries*.
848
849(defun revive-shared-libraries ()
850  (dolist (lib *shared-libraries*)
851    (setf (shlib.map lib) nil
852          (shlib.pathname lib) nil
853          (shlib.base lib) nil)
854    (let* ((soname (shlib.soname lib)))
855      (when soname
856        (with-cstrs ((soname soname))
857          (let* ((map (block found
858                        (%walk-shared-libraries
859                         #'(lambda (m)
860                             (with-macptrs (libname)
861                               (%setf-macptr libname
862                                             (soname-ptr-from-link-map m))
863                               (unless (%null-ptr-p libname)
864                                 (when (%cstrcmp soname libname)
865                                   (return-from found  m)))))))))
866            (when map
867              ;;; Sigh.  We can't reliably lookup symbols in the library
868              ;;; unless we open the library (which is, of course,
869              ;;; already open ...)  ourselves, passing in the
870              ;;; #$RTLD_GLOBAL flag.
871              #+linux-target
872              (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
873                       :address soname
874                       :unsigned-fullword *dlopen-flags*
875                       :void)
876              (setf (shlib.base lib) (%int-to-ptr (pref map :link_map.l_addr))
877                    (shlib.pathname lib) (%get-cstring
878                                          (pref map :link_map.l_name))
879                    (shlib.map lib) map))))))))
880
881;;; Repeatedly iterate over shared libraries, trying to open those
882;;; that weren't already opened by the kernel.  Keep doing this until
883;;; we reach stasis (no failures or no successes.)
884
885(defun %reopen-user-libraries ()
886  (loop
887      (let* ((win nil)
888             (lose nil))
889        (dolist (lib *shared-libraries*)
890          (let* ((map (shlib.map lib))
891                 (handle (shlib.handle lib)))
892            (unless map
893              (with-cstrs ((soname (shlib.soname lib)))
894                (setq handle
895                      (ff-call
896                       (%kernel-import target::kernel-import-GetSharedLibrary)
897                       :address soname
898                       :unsigned-fullword *dlopen-flags*
899                       :address))
900                #-(or freebsd-target solaris-target) (setq map handle)
901                #+(or freebsd-target solaris-target)
902                (setq map
903                      (if (%null-ptr-p handle)
904                        handle
905                        (rlet ((p :address))
906                          (if (eql 0 (ff-call
907                                      (foreign-symbol-entry "dlinfo")
908                                      :address handle
909                                      :int #$RTLD_DI_LINKMAP
910                                      :address p
911                                      :int))
912                            (pref p :address)
913                            (%null-ptr)))))
914                (if (%null-ptr-p map)
915                  (setq lose t)
916                  (setf (shlib.pathname lib)
917                        (%get-cstring (pref map :link_map.l_name))
918                        (shlib.base lib)
919                        (%int-to-ptr (pref map :link_map.l_addr))
920                        (shlib.map lib) map
921                        (shlib.handle lib) handle
922                        win t))))))
923        (when (or (not lose) (not win)) (return)))))
924)
925
926
927(defun refresh-external-entrypoints ()
928  #+linux-target
929  (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked))))
930  (%revive-macptr *rtld-next*)
931  (%revive-macptr *rtld-default*)
932  #+(or linux-target freebsd-target solaris-target)
933  (unless *statically-linked*
934    (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
935    (revive-shared-libraries)
936    (%reopen-user-libraries))
937  #+darwin-target
938  (progn
939    (setup-lookup-calls)
940    (reopen-user-libraries))
941  #+windows-target
942  (init-windows-ffi)
943  (when *eeps*
944    (without-interrupts 
945     (maphash #'(lambda (k v) 
946                  (declare (ignore k)) 
947                  (setf (eep.address v) nil) 
948                  (resolve-eep v nil))
949              *eeps*)))
950  (when *fvs*
951    (without-interrupts
952     (maphash #'(lambda (k v)
953                  (declare (ignore k))
954                  (setf (fv.addr v) nil)
955                  (resolve-foreign-variable v nil))
956              *fvs*))))
957
958
Note: See TracBrowser for help on using the repository browser.