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

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

Move (windows-specific) NBACKSLASH-TO-FORWARD-SLASH from level-1/linux-files
to level-0/l0-cfm-support.lisp.

Implement REVIVE-SHARED-LIBRARIES and REOPEN-USER-LIBRARIES for Windows.
Fix (windows-specific) HMODULE-PATHNAME.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 38.6 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  (defun nbackslash-to-forward-slash (namestring)
482    (dotimes (i (length namestring) namestring)
483      (when (eql (schar namestring i) #\\)
484        (setf (schar namestring i) #\/))))
485
486  (defun init-windows-ffi ()
487    (%revive-macptr *windows-invalid-handle*)
488    (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address)) 
489    (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules"))   
490    (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA"))
491    (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA"))
492    (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA")))
493
494  (init-windows-ffi)
495 
496  (defun hmodule-pathname (hmodule)
497    (do* ((bufsize 128))
498         ()
499      (%stack-block ((name bufsize))
500        (let* ((needed (ff-call *get-module-file-name-addr*
501                                :address hmodule
502                                :address name
503                                :signed-fullword bufsize
504                                :signed-fullword)))
505          (if (eql 0 needed)
506            (return nil)
507            (if (<= bufsize needed)
508              (setq bufsize (+ bufsize bufsize))
509              (return (nbackslash-to-forward-slash (%str-from-ptr name needed)))))))))
510
511  (defun hmodule-basename (hmodule)
512    (do* ((bufsize 64))
513         ()
514      (%stack-block ((name bufsize))
515        (let* ((needed (ff-call *get-module-base-name-addr*
516                                :address *current-process-handle*
517                                :address hmodule
518                                :address name
519                                :signed-fullword bufsize
520                                :signed-fullword)))
521          (if (eql 0 needed)
522            (return nil)
523            (if (< bufsize needed)
524              (setq bufsize needed)
525              (return (%str-from-ptr name needed))))))))
526
527  (defun existing-shlib-for-hmodule (hmodule)
528    (dolist (shlib *shared-libraries*)
529      (when (eql hmodule (shlib.map shlib)) (return shlib))))
530     
531 
532  (defun shared-library-from-hmodule (hmodule)
533    (or (existing-shlib-for-hmodule hmodule)
534        (let* ((shlib (%cons-shlib (hmodule-basename hmodule)
535                                   (hmodule-pathname hmodule)
536                                   hmodule
537                                   hmodule)))
538          (push shlib *shared-libraries*)
539          shlib)))
540
541  (defun for-each-loaded-module (f)
542    (let* ((have (* 16 (record-length #>HMODULE))))
543      (rlet ((pneed #>DWORD))
544        (loop
545          (%stack-block ((modules have))
546            (ff-call *enum-process-modules-addr*
547                     :address *current-process-handle*
548                     :address modules
549                     #>DWORD have
550                     :address pneed)
551            (let* ((need (pref pneed #>DWORD)))
552              (if (> need have)
553                (setq have need)
554                (return
555                  (do* ((i 0 (+ i (record-length #>HMODULE))))
556                       ((= i need))
557                    (funcall f (%get-ptr modules i)))))))))))
558
559  (defun init-shared-libraries ()
560    (for-each-loaded-module #'shared-library-from-hmodule))
561 
562  (defun shlib-containing-entry (addr &optional name)
563    (with-macptrs ((p (%int-to-ptr addr)))
564      (shlib-containing-address p name)))
565
566  (defun shlib-containing-address (addr &optional name)
567    (declare (ignore name))
568    (rlet ((phmodule :address (%null-ptr)))
569      (let* ((found (ff-call *get-module-handle-ex-addr*
570                             #>DWORD (logior
571                                      #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS
572                                      #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT)
573                             :address addr
574                             :address phmodule
575                             #>BOOL)))
576        (unless (eql 0 found)
577          (let* ((hmodule (pref phmodule :address)))
578            (dolist (lib *shared-libraries*)
579              (when (eql (shlib.map lib)  hmodule)
580                (return lib))))))))
581
582
583  (defun open-shared-library-internal (name)
584    (let* ((hmodule (with-cstrs ((name name))
585                      (ff-call
586                       (%kernel-import target::kernel-import-GetSharedLibrary)
587                       :address name
588                       :unsigned-fullword 0
589                       :address)))
590           (shlib (unless (%null-ptr-p hmodule)
591                    (shared-library-from-hmodule hmodule))))
592      (if shlib
593        (progn
594          (incf (shlib.opencount shlib))
595          (setf (shlib.handle shlib) hmodule)
596          shlib)
597        (values nil (%windows-error-string (get-last-windows-error))))))
598
599  (init-shared-libraries)
600
601  (defun revive-shared-libraries ()
602    (dolist (lib *shared-libraries*)
603      (setf (shlib.map lib) nil
604            (shlib.handle lib) nil
605            (shlib.pathname lib) nil
606            (shlib.base lib) nil)
607      (let* ((soname (shlib.soname lib))
608             (soname-len (length soname)))
609        (block found
610          (for-each-loaded-module
611           (lambda (m)
612             (let* ((module-soname (hmodule-basename m)))
613               (when (%simple-string= soname module-soname 0 0 soname-len (length module-soname))
614                 (let* ((m (%inc-ptr m 0)))
615                   (setf (shlib.base lib) m
616                         (shlib.map lib) m
617                         (shlib.pathname lib) (hmodule-pathname m)))
618                 (return-from found)))))))))
619
620  (defun reopen-user-libraries ()
621    (dolist (lib *shared-libraries*)
622      (unless (shlib.map lib)
623        (let* ((handle (with-cstrs ((name (shlib.soname lib)))
624                         (ff-call
625                          (%kernel-import target::kernel-import-GetSharedLibrary)
626                          :address name
627                          :unsigned-fullword 0
628                          :address))))
629          (unless (%null-ptr-p handle)
630            (setf (shlib.handle lib) handle
631                  (shlib.base lib) handle
632                  (shlib.map lib) handle
633                  (shlib.pathname lib) (hmodule-pathname handle)
634                  (shlib.opencount lib) 1))))))
635           
636             
637
638;;; end windows-target
639  ) 
640
641
642(defun ensure-open-shlib (c force)
643  (if (or (shlib.map c) (not force))
644    *rtld-use*
645    (error "Shared library not open: ~s" (shlib.soname c))))
646
647(defun resolve-container (c force)
648  (if c
649    (ensure-open-shlib c force)
650    *rtld-use*
651    ))
652
653
654
655
656;;; An "entry" can be fixnum (the low 2 bits are clear) which represents
657;;; a (32-bit word)-aligned address.  That convention covers all
658;;; function addresses on ppc32 and works for addresses that are
659;;; 0 mod 8 on PPC64, but can't work for things that're byte-aligned
660;;; (x8664 and other non-RISC platforms.)
661;;; For PPC64, we may have to cons up a macptr if people use broken
662;;; linkers.  (There are usually cache advantages to aligning ppc
663;;; function addresses on at least a 16-byte boundary, but some
664;;; linkers don't quite get the concept ...)
665
666(defun foreign-symbol-entry (name &optional (handle *rtld-use*))
667  "Try to resolve the address of the foreign symbol name. If successful,
668return a fixnum representation of that address, else return NIL."
669  (with-cstrs ((n name))
670    #+ppc-target
671    (with-macptrs (addr)     
672      (%setf-macptr addr
673                    (ff-call (%kernel-import target::kernel-import-FindSymbol)
674                             :address handle
675                             :address n
676                             :address))
677      (unless (%null-ptr-p addr)        ; No function can have address 0
678        (or (macptr->fixnum addr) (%inc-ptr addr 0))))
679    #+(or x8632-target arm-target)
680    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
681                          :address handle
682                          :address n
683                          :unsigned-fullword)))
684      (unless (eql 0 addr) addr))
685    #+x8664-target
686    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol)
687                          :address handle
688                          :address n
689                          :unsigned-doubleword)))
690      (unless (eql 0 addr) addr))))
691
692(defvar *statically-linked* nil)
693
694#+(or linux-target freebsd-target solaris-target)
695(progn
696
697(defun %library-base-containing-address (address)
698  (rletZ ((info :<D>l_info))
699    (let* ((status (ff-call *dladdr-entry*
700                            :address address
701                            :address info :signed-fullword)))
702      (declare (integer status))
703      (unless (zerop status)
704        (pref info :<D>l_info.dli_fbase)))))
705 
706(defun shlib-containing-address (address &optional name)
707  (declare (ignore name))
708  (let* ((base (%library-base-containing-address address)))
709    (if base
710      (shared-library-at base))))
711
712
713(defun shlib-containing-entry (entry &optional name)
714  (unless *statically-linked*
715    (with-macptrs (p)
716      (entry->addr entry p)
717      (shlib-containing-address p name))))
718)
719
720#+darwin-target
721(progn
722(defvar *dyld-image-count*)
723(defvar *dyld-get-image-header*)
724(defvar *dyld-get-image-name*)
725(defvar *nslookup-symbol-in-image*)
726(defvar *nsaddress-of-symbol*)
727(defvar *nsmodule-for-symbol*)
728(defvar *ns-is-symbol-name-defined-in-image*)
729(defvar *dladdr-entry* 0)
730
731(defun setup-lookup-calls ()
732  #+notyet
733  (setq *dladdr-entry* (foreign-symbol-entry "_dladdr"))
734  (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count"))
735  (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header"))
736  (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name"))
737  (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage"))
738  (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol"))
739  (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol"))
740  (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage")))
741
742(setup-lookup-calls)
743
744;;;
745;;; given an entry address (a number) and a symbol name (lisp string)
746;;; find the associated dylib or module
747;;; if the dylib or module is not found in *shared-libraries* list it is added
748;;; if not found in the OS list it returns nil
749;;;
750;;; got this error before putting in the call to
751;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead
752;;; lock (dyld operation attempted in a thread already doing a dyld
753;;; operation)
754;;;
755
756(defun legacy-shlib-containing-address (addr name)
757  (when *ns-is-symbol-name-defined-in-image*
758    (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword))
759      (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address)))
760        (when (and (not (%null-ptr-p header))
761                   (or (eql (pref header :mach_header.filetype) #$MH_DYLIB)
762                       (eql (pref header :mach_header.filetype) #$MH_BUNDLE)))
763          ;; make sure the image is either a bundle or a dylib
764          ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5)
765          (with-cstrs ((cname name))
766            ;; also we must check is symbol name is defined in the
767            ;; image otherwise in certain cases there is a crash,
768            ;; another likely OS bug happens in the case where a
769            ;; bundle imports a dylib and then we call
770            ;; nslookupsymbolinimage on the bundle image
771            (when (/= 0
772                      (ff-call *ns-is-symbol-name-defined-in-image* :address header
773                               :address cname :unsigned))
774              (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname
775                                     :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR
776                                     :address)))
777                (unless (%null-ptr-p symbol)
778                  ;; compare the found address to the address we are looking for
779                  (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address)))
780                    ;; (format t "Foundaddr ~s~%" foundaddr)
781                    ;; (format t "Compare to addr ~s~%" addr)
782                    (when (eql foundaddr addr)
783                      (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address))
784                             (libname (unless (%null-ptr-p imgname) (%get-cstring imgname)))
785                             (libmodule (%int-to-ptr 0))
786                             (libheader (%int-to-ptr 0)))
787                        (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE)
788                          (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address))
789                          (setf libheader header))
790                        ;; make sure that this shared library is on *shared-libraries*
791                        (return (shared-library-from-header-module-or-name libheader libmodule libname))))))))))))))
792
793(defun shlib-containing-address (address name)
794  (if (zerop *dladdr-entry*)
795    (legacy-shlib-containing-address address name)
796    ;; Bootstrapping.  RLET might be clearer here.
797    (%stack-block ((info (record-length #>Dl_info) :clear t))
798      (unless (zerop (ff-call *dladdr-entry*
799                              :address address
800                              :address info
801                              :signed-fullword))
802        (let* ((addr (pref info #>Dl_info.dli_fbase)))
803          (format t "~&name = ~s" (pref info  #>Dl_info.dli_fname))
804         
805          (dolist (lib *shared-libraries*)
806            (when (eql (shlib.base lib) addr)
807              (return lib))))))))
808
809(defun shlib-containing-entry (entry &optional name)
810  (unless name
811    (error "foreign name must be non-NIL."))
812  (with-macptrs (addr)
813    (entry->addr entry addr)
814    (shlib-containing-address addr name)))
815
816;; end Darwin progn
817)
818
819#-(or linux-target darwin-target freebsd-target solaris-target windows-target)
820(defun shlib-containing-entry (entry &optional name)
821  (declare (ignore entry name))
822  *rtld-default*)
823
824
825(defun resolve-eep (e &optional (require-resolution t))
826  (or (eep.address e)
827      (let* ((name (eep.name e))
828             (container (eep.container e))
829             (handle (resolve-container container require-resolution))
830             (addr (foreign-symbol-entry name handle)))
831        (if addr
832          (progn
833            (unless container
834              (setf (eep.container e) (shlib-containing-entry addr name)))
835            (setf (eep.address e) addr))
836          (if require-resolution
837            (error "Can't resolve foreign symbol ~s" name))))))
838
839
840
841(defun foreign-symbol-address (name &optional (map *rtld-use*))
842  "Try to resolve the address of the foreign symbol name. If successful,
843return that address encapsulated in a MACPTR, else returns NIL."
844  (with-cstrs ((n name))
845    (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address)))
846      (unless (%null-ptr-p addr)
847        addr))))
848
849(defun resolve-foreign-variable (fv &optional (require-resolution t))
850  (or (fv.addr fv)
851      (let* ((name (fv.name fv))
852             (container (fv.container fv))
853             (handle (resolve-container container require-resolution))
854             (addr (foreign-symbol-address name handle)))
855        (if addr
856          (progn
857            (unless container
858              (setf (fv.container fv) (shlib-containing-address addr name)))
859            (setf (fv.addr fv) addr))
860          (if require-resolution
861            (error "Can't resolve foreign symbol ~s" name))))))
862
863(defun load-eep (name)
864  (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name)))))
865    (resolve-eep eep nil)
866    eep))
867
868(defun load-fv (name type)
869  (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type)))))
870    (resolve-foreign-variable fv nil)
871    fv))
872
873         
874
875
876
877
878#+(or linux-target freebsd-target solaris-target)
879(progn
880
881;;; Return the position of the last dot character in name, if that
882;;; character is followed by one or more decimal digits (e.g., the
883;;; start of a numeric suffix on a library name.)  Return NIL if
884;;; there's no such suffix.
885(defun last-dot-pos (name)
886  (do* ((i (1- (length name)) (1- i))
887        (default i)
888        (trailing-digits nil))
889       ((<= i 0) default)
890    (declare (fixnum i))
891    (let* ((code (%scharcode name i)))
892      (declare (type (mod #x110000) code))
893      (if (and (>= code (char-code #\0))
894               (<= code (char-code #\9)))
895        (setq trailing-digits t)
896        (if (= code (char-code #\.))
897          (return (if trailing-digits i))
898          (return default))))))
899 
900;;; It's assumed that the set of libraries that the OS has open
901;;; (accessible via the _dl_loaded global variable) is a subset of
902;;; the libraries on *shared-libraries*.
903
904(defun revive-shared-libraries ()
905  (dolist (lib *shared-libraries*)
906    (setf (shlib.map lib) nil
907          (shlib.pathname lib) nil
908          (shlib.base lib) nil)
909    (let* ((soname (shlib.soname lib))
910           (last-dot (if soname (last-dot-pos soname))))
911      (when soname
912        (with-cstrs ((soname soname))
913          (let* ((map (block found
914                        (%walk-shared-libraries
915                         #'(lambda (m)
916                             (with-macptrs (libname)
917                               (%setf-macptr libname
918                                             (soname-ptr-from-link-map m))
919                               (unless (%null-ptr-p libname)
920                                 (when (or (%cstrcmp soname libname)
921                                           (and last-dot
922                                                (%cnstrcmp soname libname (1+ last-dot))))
923                                   (return-from found  m)))))))))
924            (when map
925              ;;; Sigh.  We can't reliably lookup symbols in the library
926              ;;; unless we open the library (which is, of course,
927              ;;; already open ...)  ourselves, passing in the
928              ;;; #$RTLD_GLOBAL flag.
929              #+linux-target
930              (ff-call (%kernel-import target::kernel-import-GetSharedLibrary)
931                       :address soname
932                       :unsigned-fullword *dlopen-flags*
933                       :void)
934              (setf (shlib.base lib) (%int-to-ptr (pref map :link_map.l_addr))
935                    (shlib.pathname lib) (%get-cstring
936                                          (pref map :link_map.l_name))
937                    (shlib.soname lib) (%get-cstring (soname-ptr-from-link-map map))
938                    (shlib.map lib) map))))))))
939
940;;; Repeatedly iterate over shared libraries, trying to open those
941;;; that weren't already opened by the kernel.  Keep doing this until
942;;; we reach stasis (no failures or no successes.)
943
944(defun %reopen-user-libraries ()
945  (loop
946      (let* ((win nil)
947             (lose nil))
948        (dolist (lib *shared-libraries*)
949          (let* ((map (shlib.map lib))
950                 (handle (shlib.handle lib)))
951            (unless map
952              (with-cstrs ((soname (shlib.soname lib)))
953                (setq handle
954                      (ff-call
955                       (%kernel-import target::kernel-import-GetSharedLibrary)
956                       :address soname
957                       :unsigned-fullword *dlopen-flags*
958                       :address))
959                #-(or freebsd-target solaris-target) (setq map handle)
960                #+(or freebsd-target solaris-target)
961                (setq map
962                      (if (%null-ptr-p handle)
963                        handle
964                        (rlet ((p :address))
965                          (if (eql 0 (ff-call
966                                      (foreign-symbol-entry "dlinfo")
967                                      :address handle
968                                      :int #$RTLD_DI_LINKMAP
969                                      :address p
970                                      :int))
971                            (pref p :address)
972                            (%null-ptr)))))
973                (if (%null-ptr-p map)
974                  (setq lose t)
975                  (setf (shlib.pathname lib)
976                        (%get-cstring (pref map :link_map.l_name))
977                        (shlib.base lib)
978                        (%int-to-ptr (pref map :link_map.l_addr))
979                        (shlib.map lib) map
980                        (shlib.handle lib) handle
981                        win t))))))
982        (when (or (not lose) (not win)) (return)))))
983)
984
985
986(defun refresh-external-entrypoints ()
987  #+linux-target
988  (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked))))
989  (%revive-macptr *rtld-next*)
990  (%revive-macptr *rtld-default*)
991  #+(or linux-target freebsd-target solaris-target)
992  (unless *statically-linked*
993    (setq *dladdr-entry* (foreign-symbol-entry "dladdr"))
994    (revive-shared-libraries)
995    (%reopen-user-libraries))
996  #+darwin-target
997  (progn
998    (setup-lookup-calls)
999    (reopen-user-libraries))
1000  #+windows-target
1001  (progn
1002    (init-windows-ffi)
1003    (revive-shared-libraries)
1004    (reopen-user-libraries))
1005  (when *eeps*
1006    (without-interrupts 
1007     (maphash #'(lambda (k v) 
1008                  (declare (ignore k)) 
1009                  (setf (eep.address v) nil) 
1010                  (resolve-eep v nil))
1011              *eeps*)))
1012  (when *fvs*
1013    (without-interrupts
1014     (maphash #'(lambda (k v)
1015                  (declare (ignore k))
1016                  (setf (fv.addr v) nil)
1017                  (resolve-foreign-variable v nil))
1018              *fvs*))))
1019
1020(defun open-shared-library (name &optional (process #+darwin-target :initial
1021                                                    #-darwin-target :current))
1022  "If the library denoted by name can be loaded by the operating system,
1023return an object of type SHLIB that describes the library; if the library
1024is already open, increment a reference count. If the library can't be
1025loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from
1026the operating system."
1027    (multiple-value-bind (lib error-string)
1028        (if (or (eq process :current)
1029                (eq process *current-process*)
1030                (and (eq process :initial)
1031                     (eq *current-process* *initial-process*)))
1032          (open-shared-library-internal name)
1033         
1034          (call-in-process (lambda () (open-shared-library-internal  name))
1035                           (if (eq process :initial)
1036                             *initial-process*
1037                             process)))
1038      (or lib
1039          (error "Error opening shared library ~a : ~a." name error-string))))
1040
1041
Note: See TracBrowser for help on using the repository browser.