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

Last change on this file since 15601 was 15425, checked in by gb, 7 years ago

armcl. armcl.image: new binaries
compiler/ARM/arm-arch.lisp: add tcr.architecture-version. Bump fasl version,

image version.

compiler/ARM/arm-asm.lisp: don't define ARMv7-specific instructions.
compiler/ARM/arm-lap.lisp: new :opcode directive, assembles arbitrary word

in code section.

compiler/ARM/arm-lapmacros.lisp: don't use v7-specific instructions. Define

clrex, dmb as macros which test architecture version at runtime. Remove
some unused things.

compiler/ARM/arm-vinsns.lisp: don't use v7-specific instructions. Remove

some more unused things.

compiler/ARM/arm2.lisp: Remove still more unused things.
level-0/ARM/arm-bignum.lisp: don't use v7-specific instructions.
level-0/l0-cfm-support.lisp: hack to try to avoid treating dynamic linker

as a shared library on Linux. (Different dynamic linkers are used for
softfp/hard float on ARM; we don't a saved image to try to re-open the
wrong one.

level-1/arm-callback-support.lisp: don't use movw instruction in callback

trampolines.

lisp-kernel/arm-asmutils.s: don't use v7-specific instructions (unless we're

sure that we're on v7 or later.)

lisp-kernel/arm-constants.h: tcr.architecture_version. Bump image version.

Define ARM CPU architecture constants.

lisp-kernel/arm-constants.s: tcr.architecture_version.
lisp-kernel/arm-macros.s: define _clrex and _dmb macros which test

tcr.arm_architecture_version at runtime.

lisp-kernel/arm-spentry.s: use _clrex macro. In _SPcheck_fpu_exception,

look for offending instuction 4 bytes further before lr (change in
subprim call mechanism.)

lisp-kernel/linuxarm/Makefile: compile/assemble for ARMv6.
lisp-kernel/lisp_globals.s: don't need to define NUM_LISP_GLOBALS anymore.
lisp-kernel/pmcl-kernel.c: check_arm_cpu() accepts ARMv6 or later.
lisp-kernel/thread-manager.c: when creating a TCR on ARM, set

tcr.architecture_version to fixnum representation of architecture - 7 (so
ARMv6 is -1, ARMv7 is 0, etc.)

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