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

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

Work around Android dynamic linker more.

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