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

Last change on this file since 14288 was 14288, checked in by gb, 9 years ago

l1-boot-2.lisp:
In INITIALIZE-INTERACTIVE-STREAMS: ensure that *STDOUT*, *STDERR*, and

(if it's disjoint) *TERMINAL-OUTPUT* are auto-flushed.

linux-files.lisp:
#+windows-target Define GET-LAST-WINDOWS-ERROR, so that #_GetLastError
can be called from code that may have to run before the FFI is
initialized.
When prompting the user to type :Y, force output. (This may run on the
housekeeping thread, so that output may not get autoflushed.)

l0-cfm-support.lisp: if GET-SHARED-LIBRARY fails, signal the error on
the calling thread (even if the #_dlopen/whatever happens on the initial
thread); fixes ticket:742

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