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

Last change on this file since 16129 was 16129, checked in by gb, 6 years ago

When walking shared libraries on Linux, don't try to determine the soname
of the kernel vdso. (We used to ignore it because it had a null pathname
in its link map entry; in recent 3.15.x kernels, it has a bogus (non-absolute)
pathname.) Fixes ticket:1208; commit new Linux images.

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