source: release/1.7/source/level-0/l0-cfm-support.lisp @ 15262

Last change on this file since 15262 was 15262, checked in by rme, 7 years ago

Delete unneeded svn:mergeinfo property on this file.

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