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

Last change on this file since 14645 was 14645, checked in by gb, 9 years ago

Start trying to get CLOSE-SHARED-LIBRARY working on all platforms.
(It's never worked on Darwin or Windows and has likely bitrotted
on ELF systems.)

Seems to still work (or work again) on Linux; needs testing (and
possibly more work) elsewhere.

One of the changes: make UNLOAD-FOREIGN-VARIABLES and
UNLOAD-LIBRARY-ENTRYPOINTS invaliate all addresses if their
LIB argument is NIL.

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