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