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

Last change on this file since 13067 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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