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

Last change on this file since 11518 was 11518, checked in by gb, 11 years ago

Define *RTLD-USE* as *RTLD-NEXT* on Solaris, *RTLD-DEFAULT* on other
platforms.

Use *RTLD-USE* as default library pseudohandle, which has the effect
of reverting Linux/FreeBSD/Darwin to previous behavior (before
Solaris support was addded.)

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