Commit | Line | Data |
---|---|---|
77dd2192 | 1 | (in-package :asdf) |
2 | ||
b33bdd39 | 3 | (eval-when (:load-toplevel :compile-toplevel :execute) |
70793093 RS |
4 | ;; ASDF defines featurep, which we don't want to clobber. As such, shadow it |
5 | ;; here and then reference it with a pkg-config: prefix below. | |
6 | (shadow :featurep) | |
b33bdd39 | 7 | (use-package :pkg-config)) |
34abe734 | 8 | |
b33bdd39 | 9 | (export '(*search-library-path-on-reload* *dso-extension* |
10 | *operation* *system* *component* library shared-object | |
11 | install-init-hook)) | |
12 | ||
13 | (defvar *dso-extension* | |
e6ab30c2 | 14 | #-(or darwin win32)"so" #+darwin"dylib" #+win32"dll") |
34abe734 | 15 | |
b33bdd39 | 16 | (defvar *search-library-path-on-reload* t) |
17 | ||
18 | ||
19 | ;;; Since Common Lisp implementations doesn't seem to agree on how to | |
20 | ;;; run init hooks, we have to add our own compatibility layer. | |
21 | ||
22 | (defvar *init-hooks* ()) | |
23 | ||
24 | (defun install-init-hook (func &optional (only-once t)) | |
25 | (if only-once | |
26 | (pushnew func *init-hooks*) | |
27 | (push func *init-hooks*))) | |
28 | ||
29 | (defun run-init-hooks () | |
30 | (mapcar #'funcall (reverse *init-hooks*))) | |
31 | ||
32 | (pushnew 'run-init-hooks | |
33 | #+cmu ext:*after-save-initializations* | |
34 | #+sbcl sb-ext:*init-hooks* | |
35 | #+clisp custom:*init-hooks*) | |
36 | ||
37 | (defvar *reload-shared-objects* () | |
38 | "List of shared objects which should be reloaded from library search | |
39 | path in saved images.") | |
40 | ||
41 | #?-(sbcl>= 1 0 22) | |
42 | (defvar *dont-save-shared-objects* () | |
43 | "List of shared objects which should not be saved in images.") | |
44 | ||
45 | (defun namestring-name (namestring) | |
46 | (let ((pos (position #\/ namestring :from-end t))) | |
47 | (if pos | |
48 | (subseq namestring (1+ pos)) | |
49 | namestring))) | |
50 | ||
51 | (defun load-shared-object (pathname &optional dont-save-p (reload-p dont-save-p)) | |
52 | (let* ((namestring (ensure-namestring pathname))) | |
53 | #?(sbcl< 1 0 22)(sb-alien:load-shared-object namestring) | |
54 | #?(sbcl>= 1 0 22) | |
55 | (sb-alien:load-shared-object namestring :dont-save dont-save-p) | |
56 | #+cmu(ext:load-foreign namestring) | |
57 | #?(clisp< 2 45)(ffi::foreign-library namestring) | |
58 | #?(clisp>= 2 45)(ffi:open-foreign-library namestring) | |
59 | (when dont-save-p | |
60 | #?-(sbcl>= 1 0 22) | |
61 | (pushnew namestring *dont-save-shared-objects* :test #'string=) | |
62 | (when reload-p | |
63 | (pushnew (namestring-name namestring) | |
64 | *reload-shared-objects* :test #'string=))))) | |
65 | ||
70793093 | 66 | #?(or (sbcl< 1 0 22) (pkg-config:featurep :cmu)) |
b33bdd39 | 67 | (progn |
68 | (defun remove-shared-objects () | |
69 | (dolist (namestring *dont-save-shared-objects*) | |
70 | #+sbcl | |
71 | (setf sb-alien::*shared-objects* | |
72 | (remove namestring sb-alien::*shared-objects* | |
73 | :key #'sb-alien::shared-object-file | |
74 | :test #'string=)) | |
75 | #+cmu | |
76 | (setf system::*global-table* | |
77 | (remove namestring system::*global-table* | |
78 | :key #'cdr :test #'string=)))) | |
79 | (pushnew 'remove-shared-objects | |
80 | #+sbcl sb-ext:*save-hooks* | |
81 | #+cmu ext:*before-save-initializations*)) | |
82 | ||
83 | (defun reload-shared-objects () | |
84 | (handler-bind (#+sbcl (style-warning #'muffle-warning)) | |
85 | (dolist (namestring (reverse *reload-shared-objects*)) | |
86 | (load-shared-object namestring)))) | |
87 | ||
88 | (install-init-hook 'reload-shared-objects) | |
89 | ||
90 | ||
1a9c1e08 | 91 | |
57f6526c | 92 | ;;; The following code is more or less copied from sb-bsd-sockets.asd, |
93 | ;;; but extended to allow flags to be set in a general way. The class | |
b133c3a7 | 94 | ;;; has been renamed from unix-dso to shared-object as this code is no |
95 | ;;; longer specific to unix | |
77dd2192 | 96 | |
57f6526c | 97 | (defclass shared-object (module) |
b133c3a7 | 98 | ((ldflags :initform nil :initarg :ldflags) |
b33bdd39 | 99 | (search :initform *search-library-path-on-reload* :initarg :search |
100 | :reader search-library-path-on-reload))) | |
57f6526c | 101 | |
102 | (defun ensure-namestring (pathname) | |
77dd2192 | 103 | (namestring |
104 | (typecase pathname | |
105 | (logical-pathname (translate-logical-pathname pathname)) | |
106 | (t pathname)))) | |
107 | ||
57f6526c | 108 | (defmethod input-files ((operation compile-op) (dso shared-object)) |
77dd2192 | 109 | (mapcar #'component-pathname (module-components dso))) |
110 | ||
57f6526c | 111 | (defmethod output-files ((operation compile-op) (dso shared-object)) |
77dd2192 | 112 | (let ((dir (component-pathname dso))) |
113 | (list | |
34abe734 | 114 | (make-pathname :type *dso-extension* |
b6f51030 | 115 | :name (component-name dso) |
77dd2192 | 116 | :directory (butlast (pathname-directory dir)) |
117 | :defaults dir)))) | |
118 | ||
57f6526c | 119 | (defmethod perform :after ((operation compile-op) (dso shared-object)) |
a4263d6d | 120 | (let ((output (first (output-files operation dso))) |
57f6526c | 121 | (inputs (mapcar #'ensure-namestring |
a4263d6d | 122 | (mapcan #'(lambda (c) |
123 | (output-files operation c)) | |
124 | (module-components dso))))) | |
77dd2192 | 125 | (unless (zerop |
e6ab30c2 | 126 | (run-shell-command "gcc ~A -o ~S ~{~S~^ ~} ~{~A~^ ~}" |
127 | #-(or darwin win32)"-shared" | |
a4263d6d | 128 | #+darwin "-bundle" |
129 | #+win32 | |
130 | (format nil "-shared -Wl,--out-implib,~S" | |
57f6526c | 131 | (ensure-namestring |
a4263d6d | 132 | (make-pathname |
133 | :type "a" | |
134 | :name (format nil "lib~Adll" (pathname-name output)) | |
135 | :defaults output))) | |
57f6526c | 136 | (ensure-namestring output) |
e6ab30c2 | 137 | inputs |
138 | (slot-value dso 'ldflags))) | |
77dd2192 | 139 | (error 'operation-error :operation operation :component dso)))) |
140 | ||
b133c3a7 | 141 | (defmethod perform ((o load-op) (dso shared-object)) |
77dd2192 | 142 | (let ((co (make-instance 'compile-op))) |
b133c3a7 | 143 | (let ((pathname (car (output-files co dso)))) |
b33bdd39 | 144 | (load-shared-object pathname (search-library-path-on-reload dso))))) |
77dd2192 | 145 | |
146 | ||
147 | ||
148 | (defclass c-source-file (source-file) | |
149 | ((cflags :initform nil :initarg :cflags) | |
150 | (optimization :initform 2 :initarg :optimization) | |
151 | (definitions :initform nil :initarg :definitions) | |
152 | (include-paths :initform nil :initarg :include-paths))) | |
153 | ||
154 | ||
155 | (defmethod output-files ((op compile-op) (c c-source-file)) | |
73572c12 | 156 | (list (make-pathname :type "o" :defaults (component-pathname c)))) |
77dd2192 | 157 | |
1bf1bfc9 RS |
158 | (defmethod component-pathname ((c c-source-file)) |
159 | (make-pathname :type "c" :name (component-name c) | |
160 | :directory (pathname-directory (call-next-method)))) | |
77dd2192 | 161 | |
162 | (defmethod perform ((op compile-op) (c c-source-file)) | |
163 | (unless | |
fb1753d9 | 164 | (= 0 (run-shell-command "gcc -Wall ~A~{ ~A~} -o ~S -c ~S" |
a4263d6d | 165 | #-win32 "-fPIC" |
166 | #+win32 "-DBUILD_DLL" | |
167 | (nconc | |
168 | (when (slot-value c 'optimization) | |
169 | (list (format nil "-O~A" (slot-value c 'optimization)))) | |
170 | (loop | |
171 | for symbol in (slot-value c 'definitions) | |
172 | collect (format nil "-D~A" symbol)) | |
173 | (loop | |
174 | for path in (slot-value c 'include-paths) | |
175 | collect (format nil "-I~A" path)) | |
176 | (slot-value c 'cflags)) | |
57f6526c | 177 | (ensure-namestring (first (output-files op c))) |
178 | (ensure-namestring (component-pathname c)))) | |
77dd2192 | 179 | (error 'operation-error :operation op :component c))) |
180 | ||
181 | ||
182 | (defmethod perform ((operation load-op) (c c-source-file)) | |
183 | t) | |
184 | ||
185 | ||
fd9d29a4 | 186 | ;;; Shared libraries |
1a9c1e08 | 187 | |
fd9d29a4 | 188 | (defclass library (component) |
57f6526c | 189 | ((libdir :initarg :libdir :initform nil) |
b133c3a7 | 190 | (libname :initarg :libname :initform nil) |
b33bdd39 | 191 | (search :initform *search-library-path-on-reload* :initarg :search |
192 | :reader search-library-path-on-reload))) | |
1a9c1e08 | 193 | |
194 | ||
3e9e71e7 | 195 | (defun split-path (path) |
fb1753d9 | 196 | (when path |
197 | (labels ((split (path) | |
198 | (unless (zerop (length path)) | |
199 | (let ((slash (position #\/ path))) | |
200 | (if slash | |
201 | (cons (subseq path 0 slash) (split (subseq path (1+ slash)))) | |
202 | (list path)))))) | |
203 | (if (and (not (zerop (length path))) (char= (char path 0) #\/)) | |
204 | (cons :absolute (split (subseq path 1))) | |
205 | (cons :relative (split path)))))) | |
206 | ||
1a9c1e08 | 207 | |
208 | (defmethod component-pathname ((lib library)) | |
fb1753d9 | 209 | (or |
210 | (when (slot-value lib 'libname) | |
211 | (let ((filename (format nil "~A~A" (namestring (make-pathname :directory (split-path (slot-value lib 'libdir)))) (slot-value lib 'libname)))) | |
212 | (when (probe-file filename) | |
213 | (pathname filename)))) | |
214 | ||
215 | (make-pathname | |
216 | :type *dso-extension* | |
217 | :name (or (slot-value lib 'libname) (component-name lib)) | |
218 | :directory (split-path (slot-value lib 'libdir))))) | |
1a9c1e08 | 219 | |
b33bdd39 | 220 | |
221 | (defvar *loaded-libraries* ()) | |
222 | ||
b133c3a7 | 223 | (defmethod perform ((o load-op) (lib library)) |
b33bdd39 | 224 | (load-shared-object (component-pathname lib) |
225 | (search-library-path-on-reload lib)) | |
226 | (pushnew lib *loaded-libraries*)) | |
fd9d29a4 | 227 | |
b133c3a7 | 228 | (defmethod perform ((operation operation) (lib library)) |
fd9d29a4 | 229 | nil) |
230 | ||
b133c3a7 | 231 | (defmethod operation-done-p ((o load-op) (lib library)) |
b33bdd39 | 232 | (find lib *loaded-libraries*)) |
fd9d29a4 | 233 | |
b133c3a7 | 234 | (defmethod operation-done-p ((o operation) (lib library)) |
fd9d29a4 | 235 | t) |
90309986 | 236 | |
237 | ||
238 | ;;; Binding of dynamic variables during perform | |
239 | ||
240 | (defvar *operation* nil) | |
241 | (defvar *system* nil) | |
242 | (defvar *component* nil) | |
243 | ||
244 | (defmethod perform :around ((operation operation) (c component)) | |
245 | (let ((*operation* operation) | |
246 | (*component* c) | |
247 | (*system* (component-system c))) | |
248 | (call-next-method))) |