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

Last change on this file since 10873 was 10873, checked in by gb, 13 years ago

Define *WINDOWS-INVALID-HANDLE*, which is EQL to what Windows returns if
it can't create a HANDLE. (Except when it returns some sort of integer ...).
Revive *WINDOWS-INVALID-HANDLE* on startup.

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