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

Last change on this file since 11919 was 11919, checked in by gb, 10 years ago

Osei Poku's patch to handle shared libraries whose names don't contain
a dot in %REVIVE-SHARED-LIBRARIES.

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