[f05756]: src / code / foreign-load.lisp Maximize Restore History

Download this file

foreign-load.lisp    210 lines (189 with data), 9.0 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
;;;; Loading shared object files
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!ALIEN")
;;; Used to serialize modifications to *shared-objects*.
(defvar *shared-objects-lock*
(sb!thread:make-mutex :name "shared object list lock"))
(define-unsupported-fun load-foreign
"Unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
"~S is unsupported as of SBCL 0.8.13. See LOAD-SHARED-OBJECT."
(load-foreign))
(define-unsupported-fun load-1-foreign
"Unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
"~S is unsupported as of SBCL 0.8.13. Please use LOAD-SHARED-OBJECT."
(load-1-foreign))
(progn
(define-alien-variable undefined-alien-address unsigned-long)
(defvar *runtime-dlhandle*))
(defvar *shared-objects*)
(defstruct shared-object pathname namestring handle dont-save)
(defun load-shared-object (pathname &key dont-save)
#!+sb-doc
"Load a shared library / dynamic shared object file / similar foreign
container specified by designated PATHNAME, such as a .so on an ELF platform.
Locating the shared object follows standard rules of the platform, consult the
manual page for dlopen(3) for details. Typically paths speficied by
environment variables such as LD_LIBRARY_PATH are searched if the PATHNAME has
no directory, but on some systems (eg. Mac OS X) search may happen even if
PATHNAME is absolute. (On Windows LoadLibrary is used instead of dlopen(3).)
On non-Windows platoforms calling LOAD-SHARED-OBJECT again with an PATHNAME
EQUAL to the designated pathname of a previous call will replace the old
definitions; if a symbol was previously referenced thru the object and is not
present in the reloaded version an error will be signalled. Reloading may not
work as expected if user or library-code has called dlopen(3) on the same
shared object.
LOAD-SHARED-OBJECT interacts with SB-EXT:SAVE-LISP-AND-DIE:
1. If DONT-SAVE is true (default is NIL), the shared object will be dropped
when SAVE-LISP-AND-DIE is called -- otherwise shared objects are reloaded
automatically when a saved core starts up. Specifying DONT-SAVE can be useful
when the location of the shared object on startup is uncertain.
2. On most platforms references in compiled code to foreign symbols in shared
objects (such as those generated by DEFINE-ALIEN-ROUTINE) remain valid across
SAVE-LISP-AND-DIE. On those platforms where this is not supported, a WARNING
will be signalled when the core is saved -- this is orthogonal from DONT-SAVE."
(let ((pathname (pathname pathname)))
(sb!thread:with-mutex (*shared-objects-lock*)
(let* ((old (find pathname *shared-objects*
:key #'shared-object-pathname
:test #'equal))
(obj (or old (make-shared-object
:pathname pathname
:namestring (native-namestring
(translate-logical-pathname pathname)
:as-file t)))))
(setf (shared-object-dont-save obj) dont-save)
;; FIXME: Why doesn's dlopen-or-lose on already loaded stuff work on
;; Windows?
;;
;; Kovalenko 2010-11-24: It would work, but it does nothing
;; useful on Windows: library reference count is increased
;; after each LoadLibrary, making it harder to unload it, and
;; that's all the effect. Also, equal pathnames on Windows
;; always designate _exactly the same library image_; Unix
;; tricks like deleting an open library and replacing it with
;; another version just don't work here.
#!-win32
(dlopen-or-lose obj)
#!+win32
(unless old
(dlopen-or-lose obj))
(setf *shared-objects* (append (remove obj *shared-objects*)
(list obj)))
;; FIXME: Why doesn't the linkage table work on Windows? (Or maybe it
;; does and this can be just #!+linkage-table?) Note: remember to change
;; FOREIGN-DEINIT as well then!
;;
;; Kovalenko 2010-11-24: I think so. Alien _data_ references
;; are the only thing on win32 that is even slightly
;; problematic. Handle function references in the same way as
;; other linkage-table platforms is easy.
;;
#!+linkage-table
(when (or old (undefined-foreign-symbols-p))
(update-linkage-table))))
pathname))
(defun unload-shared-object (pathname)
#!+sb-doc
"Unloads the shared object loaded earlier using the designated PATHNAME with
LOAD-SHARED-OBJECT, to the degree supported on the platform.
Experimental."
(let ((pathname (pathname pathname)))
(sb!thread:with-mutex (*shared-objects-lock*)
(let ((old (find pathname *shared-objects*
:key #'shared-object-pathname
:test #'equal)))
(when old
#!-hpux (dlclose-or-lose old)
(setf *shared-objects* (remove old *shared-objects*))
#!+linkage-table
(update-linkage-table))))))
(defun try-reopen-shared-object (obj)
(declare (type shared-object obj))
(tagbody :dlopen
(restart-case
(dlopen-or-lose obj)
(continue ()
:report "Skip this shared object and continue."
;; By returning NIL the shared object is dropped from the list.
(setf (shared-object-handle obj) nil)
(return-from try-reopen-shared-object nil))
(retry ()
:report "Retry loading this shared object."
(go :dlopen))
(change-pathname ()
:report "Specify a different pathname to load the shared object from."
(tagbody :query
(format *query-io* "~&Enter pathname (evaluated):~%")
(force-output *query-io*)
(let ((pathname (ignore-errors (pathname (read *query-io*)))))
(unless (pathnamep pathname)
(format *query-io* "~&Error: invalid pathname.~%")
(go :query))
(setf (shared-object-pathname obj) pathname)
(setf (shared-object-namestring obj)
(native-namestring (translate-logical-pathname pathname)
:as-file t))))
(go :dlopen))))
obj)
;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
;;; initialization.
(defun reopen-shared-objects ()
;; Ensure that the runtime is open
(setf *runtime-dlhandle* (dlopen-or-lose))
;; Reopen stuff.
(setf *shared-objects*
(remove nil (mapcar #'try-reopen-shared-object *shared-objects*))))
;;; Close all dlopened libraries and clear out sap entries in
;;; *SHARED-OBJECTS*, and drop the ones with DONT-SAVE set.
(defun close-shared-objects ()
(let (saved)
(dolist (obj (reverse *shared-objects*))
#!-hpux (dlclose-or-lose obj)
(unless (shared-object-dont-save obj)
(push obj saved)))
(setf *shared-objects* saved))
#!-hpux
(dlclose-or-lose))
(let ((symbols (make-hash-table :test #'equal))
(undefineds (make-hash-table :test #'equal)))
(defun ensure-dynamic-foreign-symbol-address (symbol &optional datap)
"Returns the address of the foreign symbol as an integer. On linkage-table
ports if the symbols isn't found a special guard address is returned instead,
accesses to which will result in an UNDEFINED-ALIEN-ERROR. On other ports an
error is immediately signalled if the symbol isn't found. The returned address
is never in the linkage-table."
(declare (ignorable datap))
(let ((addr (find-dynamic-foreign-symbol-address symbol)))
(cond #!-linkage-table
((not addr)
(error 'undefined-alien-error :name symbol))
#!+linkage-table
((not addr)
(style-warn 'sb!kernel:undefined-alien-style-warning
:symbol symbol)
(setf (gethash symbol undefineds) t)
(remhash symbol symbols)
(if datap
undefined-alien-address
(foreign-symbol-address "undefined_alien_function")))
(addr
(setf (gethash symbol symbols) t)
(remhash symbol undefineds)
addr))))
(defun undefined-foreign-symbols-p ()
(plusp (hash-table-count undefineds)))
(defun dynamic-foreign-symbols-p ()
(plusp (hash-table-count symbols)))
(defun list-dynamic-foreign-symbols ()
(loop for symbol being each hash-key in symbols
collect symbol))
(defun list-undefined-foreign-symbols ()
(loop for symbol being each hash-key in undefineds
collect symbol)))