chiark - git - mdw - clg/blob - tools/asdf-extensions.lisp

   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)))