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

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

Windows changes.

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