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

Last change on this file since 14929 was 14929, checked in by wws, 10 years ago

open-shared-library works again in FreeBSD

  • 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          (incf (shlib.opencount lib))
673          (values lib nil))))))
674
675;;;
676;;; When restarting from a saved image
677;;;
678(defun reopen-user-libraries ()
679  (dolist (lib *shared-libraries*)
680    (setf (shlib.handle lib) nil
681          (shlib.base lib) nil))
682  (dolist (lib *shared-libraries*)
683    (with-cstrs ((cname (shlib.soname lib)))
684      (let* ((handle (ff-call *dlopen-entry*
685                              :address cname
686                              :int (logior #$RTLD_GLOBAL #$RTLD_NOW)
687                              :address)))
688        (unless (%null-ptr-p handle)
689          (setf (shlib.handle lib) handle))))))
690
691(defun shlib-containing-address (address &optional name)
692  (declare (ignore name))
693  (%stack-block ((info (record-length #>Dl_info) :clear t))
694    (unless (zerop (ff-call *dladdr-entry*
695                            :address address
696                            :address info
697                            :signed-fullword))
698      (let* ((addr (pref info #>Dl_info.dli_fbase))
699             (name (%get-cstring (pref info #>Dl_info.dli_fname)))
700             (namelen (length name)))
701        (dolist (lib *shared-libraries*)
702          (let* ((shlibname  (shlib.pathname lib))
703                 (shlibnamelen (length shlibname)))
704          (when (%simple-string= name shlibname 0 0 namelen shlibnamelen)
705            (unless (shlib.base lib)
706              (setf (shlib.base lib) addr
707                    (shlib.soname lib) (soname-from-mach-header addr)))
708            (return lib))))))))
709
710(defun shlib-containing-entry (entry &optional name)
711  (unless name
712    (error "foreign name must be non-NIL."))
713  (with-macptrs (addr)
714    (entry->addr entry addr)
715    (shlib-containing-address addr name)))
716
717(defun soname-from-mach-header (header)
718  (do* ((p (%inc-ptr header
719                     #+64-bit-target (record-length :mach_header_64)
720                     #-64-bit-target (record-length :mach_header))
721           (%inc-ptr p (pref p :load_command.cmdsize)))
722        (i 0 (1+ i))
723        (n (pref header
724                 #+64-bit-target :mach_header_64.ncmds
725                 #-64-bit-target :mach_header.ncmds)))
726       ((= i n))
727    (when (= #$LC_ID_DYLIB (pref p :load_command.cmd))
728      (return (%get-cstring (%inc-ptr p (record-length :dylib_command)))))))
729
730                 
731                     
732                                                           
733(defun init-shared-libraries ()
734  (do* ((count (ff-call *dyld-image-count* :unsigned-fullword))
735        (i 1 (1+ i)))
736       ((= i count))
737    (declare (fixnum i count))
738    (let* ((addr (ff-call *dyld-get-image-header* :unsigned-fullword i :address))
739           (nameptr (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
740           (name (%get-cstring nameptr ))
741           (lib (%cons-shlib (soname-from-mach-header addr) name nil addr)))
742      (setf (shlib.handle lib)
743            (ff-call *dlopen-entry* :address nameptr :unsigned-fullword (logior #$RTLD_GLOBAL #$RTLD_NOLOAD)))
744      (push lib *shared-libraries*))))
745
746(init-shared-libraries)
747
748;; end Darwin progn
749)
750
751#-(or linux-target darwin-target freebsd-target solaris-target windows-target)
752(defun shlib-containing-entry (entry &optional name)
753  (declare (ignore entry name))
754  *rtld-default*)
755
756
757(defun resolve-eep (e &optional (require-resolution t))
758  (or (eep.address e)
759      (let* ((name (eep.name e))
760             (container (eep.container e))
761             (handle (resolve-container container require-resolution))
762             (addr (foreign-symbol-entry name handle)))
763        (if addr
764          (progn
765            (unless container
766              (setf (eep.container e) (shlib-containing-entry addr name)))
767            (setf (eep.address e) addr))
768          (if require-resolution
769            (error "Can't resolve foreign symbol ~s" name))))))
770
771
772
773(defun foreign-symbol-address (name &optional (map *rtld-use*))
774  "Try to resolve the address of the foreign symbol name. If successful,
775return that address encapsulated in a MACPTR, else returns NIL."
776  (with-cstrs ((n name))
777    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address)))
778      (unless (%null-ptr-p addr)
779        addr))))
780
781(defun resolve-foreign-variable (fv &optional (require-resolution t))
782  (or (fv.addr fv)
783      (let* ((name (fv.name fv))
784             (container (fv.container fv))
785             (handle (resolve-container container require-resolution))
786             (addr (foreign-symbol-address name handle)))
787        (if addr
788          (progn
789            (unless container
790              (setf (fv.container fv) (shlib-containing-address addr name)))
791            (setf (fv.addr fv) addr))
792          (if require-resolution
793            (error "Can't resolve foreign symbol ~s" name))))))
794
795(defun load-eep (name)
796  (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name)))))
797    (resolve-eep eep nil)
798    eep))
799
800(defun load-fv (name type)
801  (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type)))))
802    (resolve-foreign-variable fv nil)
803    fv))
804
805         
806
807
808
809
810#+(or linux-target freebsd-target solaris-target)
811(progn
812
813;;; Return the position of the last dot character in name, if that
814;;; character is followed by one or more decimal digits (e.g., the
815;;; start of a numeric suffix on a library name.)  Return NIL if
816;;; there's no such suffix.
817(defun last-dot-pos (name)
818  (do* ((i (1- (length name)) (1- i))
819        (default i)
820        (trailing-digits nil))
821       ((<= i 0) default)
822    (declare (fixnum i))
823    (let* ((code (%scharcode name i)))
824      (declare (type (mod #x110000) code))
825      (if (and (>= code (char-code #\0))
826               (<= code (char-code #\9)))
827        (setq trailing-digits t)
828        (if (= code (char-code #\.))
829          (return (if trailing-digits i))
830          (return default))))))
831 
832;;; It's assumed that the set of libraries that the OS has open
833;;; (accessible via the _dl_loaded global variable) is a subset of
834;;; the libraries on *shared-libraries*.
835
836(defun revive-shared-libraries ()
837  (dolist (lib *shared-libraries*)
838    (setf (shlib.map lib) nil
839          (shlib.pathname lib) nil
840          (shlib.base lib) nil)
841    (let* ((soname (shlib.soname lib))
842           (last-dot (if soname (last-dot-pos soname))))
843      (when soname
844        (with-cstrs ((soname soname))
845          (let* ((map (block found
846                        (%walk-shared-libraries
847                         #'(lambda (m)
848                             (with-macptrs (libname)
849                               (%setf-macptr libname
850                                             (soname-ptr-from-link-map m))
851                               (unless (%null-ptr-p libname)
852                                 (when (or (%cstrcmp soname libname)
853                                           (and last-dot
854                                                (%cnstrcmp soname libname (1+ last-dot))))
855                                   (return-from found  m)))))))))
856            (when map
857              ;;; Sigh.  We can't reliably lookup symbols in the library
858              ;;; unless we open the library (which is, of course,
859              ;;; already open ...)  ourselves, passing in the
860              ;;; #$RTLD_GLOBAL flag.
861              #+linux-target
862              (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
863                       :address soname
864                       :unsigned-fullword *dlopen-flags*
865                       :void)
866              (setf (shlib.base lib) (link_map.l_addr map)
867                    (shlib.pathname lib) (%get-cstring
868                                          (pref map :link_map.l_name))
869                    (shlib.soname lib) (%get-cstring (soname-ptr-from-link-map map))
870                    (shlib.map lib) map))))))))
871
872;;; Repeatedly iterate over shared libraries, trying to open those
873;;; that weren't already opened by the kernel.  Keep doing this until
874;;; we reach stasis (no failures or no successes.)
875
876(defun %reopen-user-libraries ()
877  (loop
878      (let* ((win nil)
879             (lose nil))
880        (dolist (lib *shared-libraries*)
881          (let* ((map (shlib.map lib))
882                 (handle (shlib.handle lib)))
883            (unless map
884              (with-cstrs ((soname (shlib.soname lib)))
885                (setq handle
886                      (ff-call
887                       (%kernel-import target::kernel-import-GetSharedLibrary)
888                       :address soname
889                       :unsigned-fullword *dlopen-flags*
890                       :address))
891                #-(or freebsd-target solaris-target) (setq map handle)
892                #+(or freebsd-target solaris-target)
893                (setq map
894                      (if (%null-ptr-p handle)
895                        handle
896                        (rlet ((p :address))
897                          (if (eql 0 (ff-call
898                                      (foreign-symbol-entry "dlinfo")
899                                      :address handle
900                                      :int #$RTLD_DI_LINKMAP
901                                      :address p
902                                      :int))
903                            (pref p :address)
904                            (%null-ptr)))))
905                (if (%null-ptr-p map)
906                  (setq lose t)
907                  (setf (shlib.pathname lib)
908                        (%get-cstring (pref map :link_map.l_name))
909                        (shlib.base lib)
910                        (link_map.l_addr map)
911                        (shlib.map lib) map
912                        (shlib.handle lib) handle
913                        win t))))))
914        (when (or (not lose) (not win)) (return)))))
915)
916
917
918(defun refresh-external-entrypoints ()
919  #+linux-target
920  (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked))))
921  (%revive-macptr *rtld-next*)
922  (%revive-macptr *rtld-default*)
923  #+(or linux-target freebsd-target solaris-target)
924  (unless *statically-linked*
925    (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
926    (revive-shared-libraries)
927    (%reopen-user-libraries))
928  #+darwin-target
929  (progn
930    (setup-lookup-calls)
931    (reopen-user-libraries))
932  #+windows-target
933  (progn
934    (init-windows-ffi)
935    (revive-shared-libraries)
936    (reopen-user-libraries))
937  (when *eeps*
938    (without-interrupts 
939     (maphash #'(lambda (k v) 
940                  (declare (ignore k)) 
941                  (setf (eep.address v) nil) 
942                  (resolve-eep v nil))
943              *eeps*)))
944  (when *fvs*
945    (without-interrupts
946     (maphash #'(lambda (k v)
947                  (declare (ignore k))
948                  (setf (fv.addr v) nil)
949                  (resolve-foreign-variable v nil))
950              *fvs*))))
951
952(defun open-shared-library (name &optional (process #+darwin-target :initial
953                                                    #-darwin-target :current))
954  "If the library denoted by name can be loaded by the operating system,
955return an object of type SHLIB that describes the library; if the library
956is already open, increment a reference count. If the library can't be
957loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
958the operating system."
959    (multiple-value-bind (lib error-string)
960        (if (or (eq process :current)
961                (eq process *current-process*)
962                (and (eq process :initial)
963                     (eq *current-process* *initial-process*)))
964          (open-shared-library-internal name)
965         
966          (call-in-process (lambda ()
967                             (handler-case (open-shared-library-internal  name)
968                               (error (condition) (values nil (format nil "~a" condition)))))
969                                                                     
970                             
971                           (if (eq process :initial)
972                             *initial-process*
973                             process)))
974      (or lib
975          (error "Error opening shared library ~a : ~a." name error-string))))
976
977
Note: See TracBrowser for help on using the repository browser.