| 1 | (in-package :asdf) |
| 2 | |
| 3 | (eval-when (:load-toplevel :compile-toplevel :execute) |
| 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) |
| 7 | (use-package :pkg-config)) |
| 8 | |
| 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* |
| 14 | #-(or darwin win32)"so" #+darwin"dylib" #+win32"dll") |
| 15 | |
| 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 | |
| 66 | #?(or (sbcl< 1 0 22) (pkg-config:featurep :cmu)) |
| 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 | |
| 91 | |
| 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 |
| 94 | ;;; has been renamed from unix-dso to shared-object as this code is no |
| 95 | ;;; longer specific to unix |
| 96 | |
| 97 | (defclass shared-object (module) |
| 98 | ((ldflags :initform nil :initarg :ldflags) |
| 99 | (search :initform *search-library-path-on-reload* :initarg :search |
| 100 | :reader search-library-path-on-reload))) |
| 101 | |
| 102 | (defun ensure-namestring (pathname) |
| 103 | (namestring |
| 104 | (typecase pathname |
| 105 | (logical-pathname (translate-logical-pathname pathname)) |
| 106 | (t pathname)))) |
| 107 | |
| 108 | (defmethod input-files ((operation compile-op) (dso shared-object)) |
| 109 | (mapcar #'component-pathname (module-components dso))) |
| 110 | |
| 111 | (defmethod output-files ((operation compile-op) (dso shared-object)) |
| 112 | (let ((dir (component-pathname dso))) |
| 113 | (list |
| 114 | (make-pathname :type *dso-extension* |
| 115 | :name (component-name dso) |
| 116 | :directory (butlast (pathname-directory dir)) |
| 117 | :defaults dir)))) |
| 118 | |
| 119 | (defmethod perform :after ((operation compile-op) (dso shared-object)) |
| 120 | (let ((output (first (output-files operation dso))) |
| 121 | (inputs (mapcar #'ensure-namestring |
| 122 | (mapcan #'(lambda (c) |
| 123 | (output-files operation c)) |
| 124 | (module-components dso))))) |
| 125 | (unless (zerop |
| 126 | (run-shell-command "gcc ~A -o ~S ~{~S~^ ~} ~{~A~^ ~}" |
| 127 | #-(or darwin win32)"-shared" |
| 128 | #+darwin "-bundle" |
| 129 | #+win32 |
| 130 | (format nil "-shared -Wl,--out-implib,~S" |
| 131 | (ensure-namestring |
| 132 | (make-pathname |
| 133 | :type "a" |
| 134 | :name (format nil "lib~Adll" (pathname-name output)) |
| 135 | :defaults output))) |
| 136 | (ensure-namestring output) |
| 137 | inputs |
| 138 | (slot-value dso 'ldflags))) |
| 139 | (error 'operation-error :operation operation :component dso)))) |
| 140 | |
| 141 | (defmethod perform ((o load-op) (dso shared-object)) |
| 142 | (let ((co (make-instance 'compile-op))) |
| 143 | (let ((pathname (car (output-files co dso)))) |
| 144 | (load-shared-object pathname (search-library-path-on-reload dso))))) |
| 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)) |
| 156 | (list (make-pathname :type "o" :defaults (component-pathname c)))) |
| 157 | |
| 158 | (defmethod component-pathname ((c c-source-file)) |
| 159 | (make-pathname :type "c" :name (component-name c) |
| 160 | :directory (pathname-directory (call-next-method)))) |
| 161 | |
| 162 | (defmethod perform ((op compile-op) (c c-source-file)) |
| 163 | (unless |
| 164 | (= 0 (run-shell-command "gcc -Wall ~A~{ ~A~} -o ~S -c ~S" |
| 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)) |
| 177 | (ensure-namestring (first (output-files op c))) |
| 178 | (ensure-namestring (component-pathname c)))) |
| 179 | (error 'operation-error :operation op :component c))) |
| 180 | |
| 181 | |
| 182 | (defmethod perform ((operation load-op) (c c-source-file)) |
| 183 | t) |
| 184 | |
| 185 | |
| 186 | ;;; Shared libraries |
| 187 | |
| 188 | (defclass library (component) |
| 189 | ((libdir :initarg :libdir :initform nil) |
| 190 | (libname :initarg :libname :initform nil) |
| 191 | (search :initform *search-library-path-on-reload* :initarg :search |
| 192 | :reader search-library-path-on-reload))) |
| 193 | |
| 194 | |
| 195 | (defun split-path (path) |
| 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 | |
| 207 | |
| 208 | (defmethod component-pathname ((lib library)) |
| 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))))) |
| 219 | |
| 220 | |
| 221 | (defvar *loaded-libraries* ()) |
| 222 | |
| 223 | (defmethod perform ((o load-op) (lib library)) |
| 224 | (load-shared-object (component-pathname lib) |
| 225 | (search-library-path-on-reload lib)) |
| 226 | (pushnew lib *loaded-libraries*)) |
| 227 | |
| 228 | (defmethod perform ((operation operation) (lib library)) |
| 229 | nil) |
| 230 | |
| 231 | (defmethod operation-done-p ((o load-op) (lib library)) |
| 232 | (find lib *loaded-libraries*)) |
| 233 | |
| 234 | (defmethod operation-done-p ((o operation) (lib library)) |
| 235 | t) |
| 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))) |