source: branches/win64/level-0/l0-cfm-support.lisp @ 8843

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

Flesh out/fix the #+windows-target stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 31.7 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
25
26
27
28
29;;; Bootstrapping. Real version is in l1-aprims.
30;;; Called by expansion of with-pstrs
31
32(defun byte-length (string &optional script start end)
33    (declare (ignore script))
34    (when (or start end)
35      (error "Don't support start or end args yet"))
36    (if (base-string-p string)
37      (length string)
38      (error "Don't support non base-string yet.")))
39
40
41
42(def-accessor-macros %svref
43  nil                                 ; 'external-entry-point
44  eep.address
45  eep.name
46  eep.container)
47
48(defun %cons-external-entry-point (name &optional container)
49  (%istruct 'external-entry-point nil name container))
50
51(defun external-entry-point-p (x)
52  (istruct-typep x 'external-entry-point))
53
54(def-accessor-macros %svref
55    nil                                 ;'foreign-variable
56  fv.addr                               ; a MACPTR, or nil
57  fv.name                               ; a string
58  fv.type                               ; a foreign type
59  fv.container                          ; containing library
60  )
61
62(defun %cons-foreign-variable (name type &optional container)
63  (%istruct 'foreign-variable nil name type container))
64
65(def-accessor-macros %svref
66    nil                                 ;'shlib
67  shlib.soname
68  shlib.pathname
69  shlib.handle                          ; if explicitly opened
70  shlib.map
71  shlib.base
72  shlib.opencount)
73
74(defun %cons-shlib (soname pathname map base)
75  (%istruct 'shlib soname pathname nil map base 0))
76
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 windows-target)  0
81                                  #-(or linux-target darwin-target windows-target)  -2))
82
83#+(or linux-target freebsd-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)
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                                 #+freebsd-target
171                                 (%inc-ptr (pref map :link_map.l_addr) disp)
172                                 #-freebsd-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 #-freebsd-target handle
305                   #+freebsd-target (if (%null-ptr-p handle)
306                                      handle
307                                      (rlet ((p :address))
308                                        (if (eql 0 (ff-call
309                                                    (foreign-symbol-entry "dlinfo")
310                                                    :address handle
311                                                    :int #$RTLD_DI_LINKMAP
312                                                    :address p
313                                                    :int))
314                                          (pref p :address)
315                                          (%null-ptr))))))
316    (if (%null-ptr-p link-map)
317      (error "Error opening shared library ~s: ~a" name (dlerror))
318      (prog1 (let* ((lib (shlib-from-map-entry link-map)))
319               (incf (shlib.opencount lib))
320               (setf (shlib.handle lib) handle)
321               lib)
322        (%walk-shared-libraries
323         #'(lambda (map)
324             (unless (shared-library-at
325                      (%int-to-ptr (pref map :link_map.l_addr)))
326               (let* ((new (shlib-from-map-entry map)))
327                 (%dlopen-shlib new)))))))))
328
329)
330
331
332#+darwin-target
333(progn
334
335(defun shared-library-with-header (header)
336  (dolist (lib *shared-libraries*)
337    (when (eql (shlib.map lib) header)
338      (return lib))))
339
340(defun shared-library-with-module (module)
341  (dolist (lib *shared-libraries*)
342    (when (eql (shlib.base lib) module)
343      (return lib))))
344
345(defun shared-library-with-name (name &optional (is-unloaded nil))
346  (let* ((namelen (length name)))
347    (dolist (lib *shared-libraries*)
348      (let* ((libname (shlib.soname lib)))
349        (when (and (%simple-string= name libname 0 0 namelen (length libname))
350                   (or (not is-unloaded) (and (null (shlib.map lib))
351                                              (null (shlib.base lib)))))
352          (return lib))))))
353
354;;;   
355;;; maybe we could fix this up name to get the "real name"
356;;; this is might be possible for dylibs but probably not for modules
357;;; for now soname and pathname are just the name that the user passed in
358;;; if the library is "discovered" later, it is the name the system gave
359;;; to it -- usually a full pathname
360;;;
361;;; header and module are ptr types
362;;;
363(defun shared-library-from-header-module-or-name (header module name)
364  ;; first try to find the library based on its address
365  (let ((found-lib (if (%null-ptr-p module)
366                       (shared-library-with-header header)
367                     (shared-library-with-module module))))
368   
369    (unless found-lib
370      ;; check if the library name is still on our list but has been unloaded
371      (setq found-lib (shared-library-with-name name t))
372      (if found-lib
373        (setf (shlib.map found-lib) header
374              (shlib.base found-lib) module)
375        ;; otherwise add it to the list
376        (push (setq found-lib (%cons-shlib name name header module))
377              *shared-libraries*)))
378    found-lib))
379
380
381(defun open-shared-library (name)
382  "If the library denoted by name can be loaded by the operating system,
383return an object of type SHLIB that describes the library; if the library
384is already open, increment a reference count. If the library can't be
385loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
386the operating system."
387  (rlet ((type :signed))
388    (let ((result (with-cstrs ((cname name))
389                    (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
390                             :address cname
391                             :address type
392                             :address))))
393        (cond
394         ((= 1 (pref type :signed))
395          ;; dylib
396          (shared-library-from-header-module-or-name result (%null-ptr) name))
397         ((= 2 (pref type :signed))
398          ;; bundle
399          (shared-library-from-header-module-or-name (%null-ptr) result name))
400         ((= 0 (pref type :signed))
401          ;; neither a dylib nor bundle was found
402          (error "Error opening shared library ~s: ~a" name
403                 (%get-cstring result)))
404         (t (error "Unknown error opening shared library ~s." name))))))
405
406;;; Walk over all registered entrypoints, invalidating any whose container
407;;; is the specified library.  Return true if any such entrypoints were
408;;; found.
409;;;
410;;; SAME AS LINUX VERSION
411;;;
412(defun unload-library-entrypoints (lib)
413  (let* ((count 0))
414    (declare (fixnum count))
415    (maphash #'(lambda (k eep)
416                 (declare (ignore k))
417                 (when (eq (eep.container eep) lib)
418                   (setf (eep.address eep) nil)
419                   (incf count)))
420             (eeps))   
421    (not (zerop count))))
422
423;;;
424;;; When restarting from a saved image
425;;;
426(defun reopen-user-libraries ()
427  (dolist (lib *shared-libraries*)
428    (setf (shlib.map lib) nil
429          (shlib.base lib) nil))
430  (loop
431      (let* ((win nil)
432             (lose nil))
433        (dolist (lib *shared-libraries*)
434          (let* ((header (shlib.map lib))
435                 (module (shlib.base lib)))
436            (unless (and header module)
437              (rlet ((type :signed))
438                (let ((result (with-cstrs ((cname (shlib.soname lib)))
439                                (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
440                                         :address cname
441                                         :address type
442                                         :address))))
443                  (cond
444                   ((= 1 (pref type :signed))
445                    ;; dylib
446                    (setf (shlib.map lib) result
447                          (shlib.base lib) (%null-ptr)
448                          win t))
449                   ((= 2 (pref type :signed))
450                    ;; bundle
451                    (setf (shlib.map lib) (%null-ptr)
452                          (shlib.base lib) result
453                          win t))
454                   (t
455                    ;; neither a dylib nor bundle was found
456                    (setq lose t))))))))
457        (when (or (not lose) (not win)) (return)))))
458
459;;; end darwin-target
460  ) 
461
462#+windows-target
463(progn
464  (defvar *current-process-handle*)
465  (defvar *enum-process-modules-addr*)
466  (defvar *get-module-file-name-addr*)
467  (defvar *get-module-base-name-addr*)
468  (defvar *get-module-handle-ex-addr*)
469
470
471  (defun init-windows-ffi ()
472    (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address)) 
473    (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules"))   
474    (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA"))
475    (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA"))
476    (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA")))
477
478  (init-windows-ffi)
479 
480  (defun hmodule-pathname (hmodule)
481    (do* ((bufsize 64))
482         ()
483      (%stack-block ((name bufsize))
484        (let* ((needed (ff-call *get-module-file-name-addr*
485                                :address *current-process-handle*
486                                :address hmodule
487                                :address name
488                                :signed-fullword bufsize
489                                :signed-fullword)))
490          (if (eql 0 needed)
491            (return nil)
492            (if (< bufsize needed)
493              (setq bufsize needed)
494              (return (%str-from-ptr name needed))))))))
495
496  (defun hmodule-basename (hmodule)
497    (do* ((bufsize 64))
498         ()
499      (%stack-block ((name bufsize))
500        (let* ((needed (ff-call *get-module-base-name-addr*
501                                :address *current-process-handle*
502                                :address hmodule
503                                :address name
504                                :signed-fullword bufsize
505                                :signed-fullword)))
506          (if (eql 0 needed)
507            (return nil)
508            (if (< bufsize needed)
509              (setq bufsize needed)
510              (return (%str-from-ptr name needed))))))))
511
512  (defun existing-shlib-for-hmodule (hmodule)
513    (dolist (shlib *shared-libraries*)
514      (when (eql hmodule (shlib.map shlib)) (return shlib))))
515     
516 
517  (defun shared-library-from-hmodule (hmodule)
518    (or (existing-shlib-for-hmodule hmodule)
519        (let* ((shlib (%cons-shlib (hmodule-basename hmodule)
520                                   (hmodule-pathname hmodule)
521                                   hmodule
522                                   hmodule)))
523          (push shlib *shared-libraries*)
524          shlib)))
525
526  (defun for-each-loaded-module (f)
527    (let* ((have (* 16 (record-length #>HMODULE))))
528      (rlet ((pneed #>DWORD))
529        (loop
530          (%stack-block ((modules have))
531            (ff-call *enum-process-modules-addr*
532                     :address *current-process-handle*
533                     :address modules
534                     #>DWORD have
535                     :address pneed)
536            (let* ((need (pref pneed #>DWORD)))
537              (if (> need have)
538                (setq have need)
539                (return
540                  (do* ((i 0 (+ i (record-length #>HMODULE))))
541                       ((= i need))
542                    (funcall f (%get-ptr modules i)))))))))))
543
544  (defun init-shared-libraries ()
545    (for-each-loaded-module #'shared-library-from-hmodule))
546 
547  (defun shlib-containing-entry (addr &optional name)
548    (with-macptrs ((p (%int-to-ptr addr)))
549      (shlib-containing-address p name)))
550
551  (defun shlib-containing-address (addr &optional name)
552    (declare (ignore name))
553    (rlet ((phmodule :address +null-ptr+))
554      (let* ((found (ff-call *get-module-handle-ex-addr*
555                             #>DWORD (logior
556                                      #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
557                                      #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT)
558                             :address addr
559                             :address phmodule
560                             #>BOOL)))
561        (unless (eql 0 found)
562          (let* ((hmodule (pref phmodule :address)))
563            (dolist (lib *shared-libraries*)
564              (when (eql (shlib.map lib)  hmodule)
565                (return lib))))))))
566
567
568  (defun open-shared-library (name)
569    "If the library denoted by name can be loaded by the operating system,
570return an object of type SHLIB that describes the library; if the library
571is already open, increment a reference count. If the library can't be
572loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
573the operating system."
574    (let* ((hmodule (with-cstrs ((name name))
575                      (ff-call
576                       (%kernel-import target::kernel-import-GetSharedLibrary)
577                       :address name
578                       :unsigned-fullword 0
579                       :address)))
580           (shlib (unless (%null-ptr-p hmodule)
581                    (shared-library-from-hmodule hmodule))))
582      (if shlib
583        (progn
584          (incf (shlib.opencount shlib))
585          (setf (shlib.handle shlib) hmodule)
586          shlib)
587        (error "Can't open shared library ~s" name))))
588
589(init-shared-libraries)
590
591;;; end windows-target
592) 
593
594
595(defun ensure-open-shlib (c force)
596  (if (or (shlib.map c) (not force))
597    *rtld-default*
598    (error "Shared library not open: ~s" (shlib.soname c))))
599
600(defun resolve-container (c force)
601  (if c
602    (ensure-open-shlib c force)
603    *rtld-default*
604    ))
605
606
607
608
609;;; An "entry" can be fixnum (the low 2 bits are clear) which represents
610;;; a (32-bit word)-aligned address.  That convention covers all
611;;; function addresses on ppc32 and works for addresses that are
612;;; 0 mod 8 on PPC64, but can't work for things that're byte-aligned
613;;; (x8664 and other non-RISC platforms.)
614;;; For PPC64, we may have to cons up a macptr if people use broken
615;;; linkers.  (There are usually cache advantages to aligning ppc
616;;; function addresses on at least a 16-byte boundary, but some
617;;; linkers don't quite get the concept ...)
618
619(defun foreign-symbol-entry (name &optional (handle *rtld-default*))
620  "Try to resolve the address of the foreign symbol name. If successful,
621return a fixnum representation of that address, else return NIL."
622  (with-cstrs ((n name))
623    #+ppc-target
624    (with-macptrs (addr)     
625      (%setf-macptr addr
626                    (ff-call (%kernel-import target::kernel-import-FindSymbol)
627                             :address handle
628                             :address n
629                             :address))
630      (unless (%null-ptr-p addr)        ; No function can have address 0
631        (or (macptr->fixnum addr) (%inc-ptr addr 0))))
632    #+x8664-target
633    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
634                          :address handle
635                          :address n
636                          :unsigned-doubleword)))
637      (unless (eql 0 addr) addr))))
638
639(defvar *statically-linked* nil)
640
641#+(or linux-target freebsd-target)
642(progn
643
644(defun %library-base-containing-address (address)
645  (rletZ ((info :<D>l_info))
646    (let* ((status (ff-call *dladdr-entry*
647                            :address address
648                            :address info :signed-fullword)))
649      (declare (integer status))
650      (unless (zerop status)
651        (pref info :<D>l_info.dli_fbase)))))
652 
653(defun shlib-containing-address (address &optional name)
654  (declare (ignore name))
655  (let* ((base (%library-base-containing-address address)))
656    (if base
657      (shared-library-at base))))
658
659
660(defun shlib-containing-entry (entry &optional name)
661  (unless *statically-linked*
662    (with-macptrs (p)
663      #+ppc-target (%setf-macptr-to-object p entry)
664      #+x86-target (%setf-macptr p (%int-to-ptr entry))
665      (shlib-containing-address p name))))
666)
667
668#+darwin-target
669(progn
670(defvar *dyld-image-count*)
671(defvar *dyld-get-image-header*)
672(defvar *dyld-get-image-name*)
673(defvar *nslookup-symbol-in-image*)
674(defvar *nsaddress-of-symbol*)
675(defvar *nsmodule-for-symbol*)
676(defvar *ns-is-symbol-name-defined-in-image*)
677
678(defun setup-lookup-calls ()
679  (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count"))
680  (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header"))
681  (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name"))
682  (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage"))
683  (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol"))
684  (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol"))
685  (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage")))
686
687(setup-lookup-calls)
688
689;;;
690;;; given an entry address (a number) and a symbol name (lisp string)
691;;; find the associated dylib or module
692;;; if the dylib or module is not found in *shared-libraries* list it is added
693;;; if not found in the OS list it returns nil
694;;;
695;;; got this error before putting in the call to
696;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead
697;;; lock (dyld operation attempted in a thread already doing a dyld
698;;; operation)
699;;;
700
701(defun shlib-containing-address (addr name)
702  (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword))
703    (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address)))
704      (when (and (not (%null-ptr-p header))
705                 (or (eql (pref header :mach_header.filetype) #$MH_DYLIB)
706                     (eql (pref header :mach_header.filetype) #$MH_BUNDLE)))
707        ;; make sure the image is either a bundle or a dylib
708        ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5)
709        (with-cstrs ((cname name))
710          ;; also we must check is symbol name is defined in the
711          ;; image otherwise in certain cases there is a crash,
712          ;; another likely OS bug happens in the case where a
713          ;; bundle imports a dylib and then we call
714          ;; nslookupsymbolinimage on the bundle image
715          (when (/= 0
716                    (ff-call *ns-is-symbol-name-defined-in-image* :address header
717                             :address cname :unsigned))
718            (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname
719                                   :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR
720                                   :address)))
721              (unless (%null-ptr-p symbol)
722                ;; compare the found address to the address we are looking for
723                (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address)))
724                  ;; (format t "Foundaddr ~s~%" foundaddr)
725                  ;; (format t "Compare to addr ~s~%" addr)
726                  (when (eql foundaddr addr)
727                    (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
728                           (libname (unless (%null-ptr-p imgname) (%get-cstring imgname)))
729                           (libmodule (%int-to-ptr 0))
730                           (libheader (%int-to-ptr 0)))
731                      (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE)
732                        (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address))
733                        (setf libheader header))
734                      ;; make sure that this shared library is on *shared-libraries*
735                      (return (shared-library-from-header-module-or-name libheader libmodule libname)))))))))))))
736
737(defun shlib-containing-entry (entry &optional name)
738  (when (not name)
739        (error "shared library name must be non-NIL."))
740  (with-macptrs (addr)
741    (%setf-macptr-to-object addr entry)
742    (shlib-containing-address addr name)))
743
744;; end Darwin progn
745)
746
747#-(or linux-target darwin-target freebsd-target windows-target)
748(defun shlib-containing-entry (entry &optional name)
749  (declare (ignore entry name))
750  *rtld-default*)
751
752
753(defun resolve-eep (e &optional (require-resolution t))
754  (or (eep.address e)
755      (let* ((name (eep.name e))
756             (container (eep.container e))
757             (handle (resolve-container container require-resolution))
758             (addr (foreign-symbol-entry name handle)))
759        (if addr
760          (progn
761            (unless container
762              (setf (eep.container e) (shlib-containing-entry addr name)))
763            (setf (eep.address e) addr))
764          (if require-resolution
765            (error "Can't resolve foreign symbol ~s" name))))))
766
767
768
769(defun foreign-symbol-address (name &optional (map *rtld-default*))
770  "Try to resolve the address of the foreign symbol name. If successful,
771return that address encapsulated in a MACPTR, else returns NIL."
772  (with-cstrs ((n name))
773    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address)))
774      (unless (%null-ptr-p addr)
775        addr))))
776
777(defun resolve-foreign-variable (fv &optional (require-resolution t))
778  (or (fv.addr fv)
779      (let* ((name (fv.name fv))
780             (container (fv.container fv))
781             (handle (resolve-container container require-resolution))
782             (addr (foreign-symbol-address name handle)))
783        (if addr
784          (progn
785            (unless container
786              (setf (fv.container fv) (shlib-containing-address addr name)))
787            (setf (fv.addr fv) addr))
788          (if require-resolution
789            (error "Can't resolve foreign symbol ~s" name))))))
790
791(defun load-eep (name)
792  (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name)))))
793    (resolve-eep eep nil)
794    eep))
795
796(defun load-fv (name type)
797  (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type)))))
798    (resolve-foreign-variable fv nil)
799    fv))
800
801         
802
803
804
805
806#+(or linux-target freebsd-target)
807(progn
808;;; It's assumed that the set of libraries that the OS has open
809;;; (accessible via the _dl_loaded global variable) is a subset of
810;;; the libraries on *shared-libraries*.
811
812(defun revive-shared-libraries ()
813  (dolist (lib *shared-libraries*)
814    (setf (shlib.map lib) nil
815          (shlib.pathname lib) nil
816          (shlib.base lib) nil)
817    (let* ((soname (shlib.soname lib)))
818      (when soname
819        (with-cstrs ((soname soname))
820          (let* ((map (block found
821                        (%walk-shared-libraries
822                         #'(lambda (m)
823                             (with-macptrs (libname)
824                               (%setf-macptr libname
825                                             (soname-ptr-from-link-map m))
826                               (unless (%null-ptr-p libname)
827                                 (when (%cstrcmp soname libname)
828                                   (return-from found  m)))))))))
829            (when map
830              ;;; Sigh.  We can't reliably lookup symbols in the library
831              ;;; unless we open the library (which is, of course,
832              ;;; already open ...)  ourselves, passing in the
833              ;;; #$RTLD_GLOBAL flag.
834              #+linux-target
835              (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
836                       :address soname
837                       :unsigned-fullword *dlopen-flags*
838                       :void)
839              (setf (shlib.base lib) (%int-to-ptr (pref map :link_map.l_addr))
840                    (shlib.pathname lib) (%get-cstring
841                                          (pref map :link_map.l_name))
842                    (shlib.map lib) map))))))))
843
844;;; Repeatedly iterate over shared libraries, trying to open those
845;;; that weren't already opened by the kernel.  Keep doing this until
846;;; we reach stasis (no failures or no successes.)
847
848(defun %reopen-user-libraries ()
849  (loop
850      (let* ((win nil)
851             (lose nil))
852        (dolist (lib *shared-libraries*)
853          (let* ((map (shlib.map lib)))
854            (unless map
855              (with-cstrs ((soname (shlib.soname lib)))
856                (setq map (ff-call
857                           (%kernel-import target::kernel-import-GetSharedLibrary)
858                           :address soname
859                           :unsigned-fullword *dlopen-flags*
860                           :address))
861                (if (%null-ptr-p map)
862                  (setq lose t)
863                  (setf (shlib.pathname lib)
864                        (%get-cstring (pref map :link_map.l_name))
865                        (shlib.base lib)
866                        (%int-to-ptr (pref map :link_map.l_addr))
867                        (shlib.map lib) map
868                        win t))))))
869        (when (or (not lose) (not win)) (return)))))
870)
871
872
873(defun refresh-external-entrypoints ()
874  #+linux-target
875  (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked))))
876  (%revive-macptr *rtld-next*)
877  (%revive-macptr *rtld-default*)
878  #+(or linux-target freebsd-target)
879  (unless *statically-linked*
880    (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
881    (revive-shared-libraries)
882    (%reopen-user-libraries))
883  #+darwin-target
884  (progn
885    (setup-lookup-calls)
886    (reopen-user-libraries))
887  (when *eeps*
888    (without-interrupts 
889     (maphash #'(lambda (k v) 
890                  (declare (ignore k)) 
891                  (setf (eep.address v) nil) 
892                  (resolve-eep v nil))
893              *eeps*)))
894  (when *fvs*
895    (without-interrupts
896     (maphash #'(lambda (k v)
897                  (declare (ignore k))
898                  (setf (fv.addr v) nil)
899                  (resolve-foreign-variable v nil))
900              *fvs*))))
901
902
Note: See TracBrowser for help on using the repository browser.