bundle.lisp 27.4 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; ASDF-Bundle

4
(uiop/package:define-package :asdf/bundle
5
  (:recycle :asdf/bundle :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade
7
   :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
8
   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
9
  (:export
10
   #:bundle-op #:bundle-type #:program-system
11
   #:bundle-system #:bundle-pathname-type #:direct-dependency-files
12
   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
13 14
   #:basic-compile-bundle-op #:prepare-bundle-op
   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
15 16
   #:lib-op #:monolithic-lib-op
   #:dll-op #:monolithic-dll-op
17 18
   #:deliver-asd-op #:monolithic-deliver-asd-op
   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
19
   #:user-system-p #:user-system #:trivial-system-p
20
   #:make-build
21
   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
22 23
(in-package :asdf/bundle)

24
(with-upgradability ()
25
  (defclass bundle-op (basic-compile-op)
26
    ((build-args :initarg :args :initform nil :accessor extra-build-args)
27 28
     (name-suffix :initarg :name-suffix :initform nil)
     (bundle-type :initform :no-output-file :reader bundle-type)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
29
     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))
30

31 32 33 34 35 36 37 38 39
  (defclass monolithic-op (operation) ()
    (:documentation "A MONOLITHIC operation operates on a system *and all of its
dependencies*.  So, for example, a monolithic concatenate operation will
concatenate together a system's components and all of its dependencies, but a
simple concatenate operation will concatenate only the components of the system
itself.")) ;; operation on a system and its dependencies

  (defclass monolithic-bundle-op (monolithic-op bundle-op)
    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation
40 41
    ((prologue-code :initform nil :accessor prologue-code)
     (epilogue-code :initform nil :accessor epilogue-code)))
42

43
  (defclass program-system (system)
44
    ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
45 46
    ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
     (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
47
     (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
48
     (prefix-lisp-object-files :initarg :prefix-lisp-object-files
49
                               :initform nil :accessor prefix-lisp-object-files)
50
     (postfix-lisp-object-files :initarg :postfix-lisp-object-files
51 52 53
                                :initform nil :accessor postfix-lisp-object-files)
     (extra-object-files :initarg :extra-object-files
                         :initform nil :accessor extra-object-files)
54
     (extra-build-args :initarg :extra-build-args
55
                       :initform nil :accessor extra-build-args)))
56

57 58
  (defmethod prologue-code ((x t)) nil)
  (defmethod epilogue-code ((x t)) nil)
59
  (defmethod no-uiop ((x t)) nil)
60 61 62 63
  (defmethod prefix-lisp-object-files ((x t)) nil)
  (defmethod postfix-lisp-object-files ((x t)) nil)
  (defmethod extra-object-files ((x t)) nil)
  (defmethod extra-build-args ((x t)) nil)
64 65 66 67 68

  (defclass link-op (bundle-op) ()
    (:documentation "Abstract operation for linking files together"))

  (defclass gather-op (bundle-op)
69 70
    ((gather-op :initform nil :allocation :class :reader gather-op)
     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
    (:documentation "Abstract operation for gathering many input files from a system"))

  (defun operation-monolithic-p (op)
    (typep op 'monolithic-op))

  (defmethod component-depends-on ((o gather-op) (s system))
    (let* ((mono (operation-monolithic-p o))
           (deps
             (required-components
              s :other-systems mono :component-type (if mono 'system '(not system))
                :goal-operation (find-operation o 'load-op)
                :keep-operation 'compile-op)))
      ;; NB: the explicit make-operation on ECL and MKCL
      ;; ensures that we drop the original-initargs and its magic flags when recursing.
      `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps)
        ,@(call-next-method))))
87

88
  ;; create a single fasl for the entire library
89
  (defclass basic-compile-bundle-op (bundle-op)
90 91 92
    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
                  :allocation :class)
     (bundle-type :initform :fasl :allocation :class)))
93

94
  (defclass prepare-bundle-op (sideway-operation)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
95 96 97
    ((sideway-operation
      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
      :allocation :class)))
98 99

  (defclass lib-op (link-op gather-op non-propagating-operation)
100 101
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :lib :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
102 103 104 105 106 107 108 109
    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
for all the linkable object files associated with the system. Compare with DLL-OP.

On most implementations, these object files only include extensions to the runtime
written in C or another language with a compiler producing linkable object files.
On CLASP, ECL, MKCL, these object files also include the contents of Lisp files
themselves. In any case, this operation will produce what you need to further build
a static runtime for your system, or a dynamic library to load in an existing runtime."))
110

111
  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
112 113
                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
    ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
114 115 116 117 118
                         :allocation :class))
    (:documentation "This operator is an alternative to COMPILE-OP. Build a system
and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
of one per source file, which may be more resource efficient.  That monolithic
FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))
119

120
  (defclass load-bundle-op (basic-load-op selfward-operation)
121 122 123 124 125
    ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
    (:documentation "This operator is an alternative to LOAD-OP. Build a system
and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
respect to LOAD-OP is that it builds only a single FASL, which may be
faster and more resource efficient."))
126 127

  ;; NB: since the monolithic-op's can't be sideway-operation's,
128
  ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
129
  ;; we'd have to have the monolithic-op not inherit from the main op,
130
  ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
131

132
  (defclass dll-op (link-op gather-op non-propagating-operation)
133 134
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :dll :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
135 136
    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
for all the linkable object files associated with the system. Compare with LIB-OP."))
137

138
  (defclass deliver-asd-op (basic-compile-op selfward-operation)
139 140 141 142 143
    ((selfward-operation
      ;; TODO: implement link-op on all implementations, and make that
      ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
      :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
      :allocation :class))
144
    (:documentation "produce an asd file for delivering the system as a single fasl"))
145 146


147
  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
148
    ((selfward-operation
149 150
      ;; TODO: implement link-op on all implementations, and make that
      ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
151 152
      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
      :allocation :class))
153 154
    (:documentation "produce fasl and asd files for combined system and dependencies."))

155 156 157 158 159 160 161
  (defclass monolithic-compile-bundle-op
      (monolithic-bundle-op basic-compile-bundle-op
       #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation)
    ((gather-op :initform #-(or clasp ecl mkcl) 'compile-bundle-op #+(or clasp ecl mkcl) 'lib-op
                :allocation :class)
     (gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :static-library
                  :allocation :class))
162
    (:documentation "Create a single fasl for the system and its dependencies."))
163

164 165 166 167
  (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
    ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
    (:documentation "Load a single fasl for the system and its dependencies."))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
168 169
  (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation)
    ((gather-type :initform :static-library :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
170 171
    (:documentation "Compile the system and produce a linkable static library (.a/.lib)
for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
172

173
  (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
174
    ((gather-type :initform :static-library :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
175 176
    (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
177

178
  (defclass image-op (monolithic-bundle-op selfward-operation
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
179
                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
180
    ((bundle-type :initform :image)
181
     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
182
     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
183 184 185 186
    (:documentation "create an image file from the system and its dependencies"))

  (defclass program-op (image-op)
    ((bundle-type :initform :program))
187
    (:documentation "create an executable file from the system and its dependencies"))
188 189 190

  (defun bundle-pathname-type (bundle-type)
    (etypecase bundle-type
191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
      ((or null string) ;; pass through nil or string literal
       bundle-type)
      ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
       (error "No output file, therefore no pathname type"))
      ((eql :fasl) ;; the type of a fasl
       #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
       #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles
      ((member :image)
       #+allegro "dxl"
       #+(and clisp os-windows) "exe"
       #-(or allegro (and clisp os-windows)) "image")
      ;; NB: on CLASP and ECL these implementations, we better agree with
      ;; (compile-file-type :type bundle-type))
      ((eql :object) ;; the type of a linkable object file
       (os-cond ((os-unix-p) "o")
                ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
      ((member :lib :static-library) ;; the type of a linkable library
       (os-cond ((os-unix-p) "a")
                ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
      ((member :dll :shared-library) ;; the type of a shared library
       (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
      ((eql :program) ;; the type of an executable program
       (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
214 215

  (defun bundle-output-files (o c)
216 217 218 219 220 221 222
    (let ((bundle-type (bundle-type o)))
      (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
                  (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
        (let ((name (or (component-build-pathname c)
                        (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
              (type (bundle-pathname-type bundle-type)))
          (values (list (subpathname (component-pathname c) name :type type))
223 224 225 226
                  (eq (class-of o) (coerce-class (component-build-operation c)
                                                 :package :asdf/interface
                                                 :super 'operation
                                                 :error nil)))))))
227 228 229 230

  (defmethod output-files ((o bundle-op) (c system))
    (bundle-output-files o c))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
231
  #-(or clasp ecl mkcl)
232 233 234 235 236
  (progn
    (defmethod perform ((o image-op) (c system))
      (dump-image (output-file o c) :executable (typep o 'program-op)))
    (defmethod perform :before ((o program-op) (c system))
      (setf *image-entry-point* (ensure-function (component-entry-point c)))))
237 238

  (defclass compiled-file (file-component)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
239
    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))
240 241 242 243 244 245 246 247

  (defclass precompiled-system (system)
    ((build-pathname :initarg :fasl)))

  (defclass prebuilt-system (system)
    ((build-pathname :initarg :static-library :initarg :lib
                     :accessor prebuilt-system-static-library))))

248 249 250 251 252 253 254 255 256

;;;
;;; BUNDLE-OP
;;;
;;; This operation takes all components from one or more systems and
;;; creates a single output file, which may be
;;; a FASL, a statically linked library, a shared library, etc.
;;; The different targets are defined by specialization.
;;;
257 258 259 260
(with-upgradability ()
  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
                                         &key (name-suffix nil name-suffix-p)
                                         &allow-other-keys)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
261
    (declare (ignore initargs name-suffix))
262 263 264
    (unless name-suffix-p
      (setf (slot-value instance 'name-suffix)
            (unless (typep instance 'program-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
265 266
              ;; "." is no good separator for Logical Pathnames, so we use "--"
              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
267
    (when (typep instance 'monolithic-bundle-op)
268
      (destructuring-bind (&key lisp-files prologue-code epilogue-code
269 270
                           &allow-other-keys)
          (operation-original-initargs instance)
271 272
        (setf (prologue-code instance) prologue-code
              (epilogue-code instance) epilogue-code)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
273 274
        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
275
    (setf (extra-build-args instance)
276
          (remove-plist-keys
277 278
           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
279
           (operation-original-initargs instance))))
280 281 282 283 284 285

  (defgeneric* (trivial-system-p) (component))

  (defun user-system-p (s)
    (and (typep s 'system)
         (not (builtin-system-p s))
286
         (not (trivial-system-p s)))))
287

288
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
289
  (deftype user-system () '(and system (satisfies user-system-p))))
290 291 292 293 294 295 296 297 298

;;;
;;; First we handle monolithic bundles.
;;; These are standalone systems which contain everything,
;;; including other ASDF systems required by the current one.
;;; A PROGRAM is always monolithic.
;;;
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
299 300
(with-upgradability ()
  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
301 302
    ;; This file selects output files from direct dependencies;
    ;; your component-depends-on method better gathered the correct dependencies in the correct order.
303 304
    (while-collecting (collect)
      (map-direct-dependencies
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
305 306 307
       t o c #'(lambda (sub-o sub-c)
                 (loop :for f :in (funcall key sub-o sub-c)
                       :when (funcall test f) :do (collect f))))))
308

309
  (defun pathname-type-equal-function (type)
310
    #'(lambda (p) (equalp (pathname-type p) type)))
311

312
  (defmethod input-files ((o gather-op) (c system))
313
    (unless (eq (bundle-type o) :no-output-file)
314 315 316
      (direct-dependency-files
       o c :key 'output-files
           :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
317 318 319 320 321 322 323 324

  (defun select-bundle-operation (type &optional monolithic)
    (ecase type
      ((:dll :shared-library)
       (if monolithic 'monolithic-dll-op 'dll-op))
      ((:lib :static-library)
       (if monolithic 'monolithic-lib-op 'lib-op))
      ((:fasl)
325
       (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
326 327
      ((:image)
       'image-op)
328 329 330
      ((:program)
       'program-op)))

331 332 333 334
  ;; DEPRECATED. This is originally from asdf-ecl.lisp.
  ;; It must die, and so must any use of initargs in operation,
  ;; unless keys to the asdf-cache are substantially modified to accommodate for them.
  ;; Coordinate with the ECL maintainers to get them to stop using it.
335 336 337 338 339 340
  (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
                             (move-here nil move-here-p)
                             &allow-other-keys)
    (let* ((operation-name (select-bundle-operation type monolithic))
           (move-here-path (if (and move-here
                                    (typep move-here '(or pathname string)))
341
                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
342 343 344 345 346 347 348
                               (system-relative-pathname system "asdf-output/")))
           (operation (apply #'operate operation-name
                             system
                             (remove-plist-keys '(:monolithic :type :move-here) args)))
           (system (find-system system))
           (files (and system (output-files operation system))))
      (if (or move-here (and (null move-here-p)
349
                             (member operation-name '(:program :image))))
350 351 352 353 354
          (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
                :for f :in files
                :for new-f = (make-pathname :name (pathname-name f)
                                            :type (pathname-type f)
                                            :defaults dest-path)
355 356
                :do (handler-case (rename-file-overwriting-target f new-f)
                      (file-error (c)
Elias Pipping's avatar
Elias Pipping committed
357
                        (declare (ignore c))
358 359
                        (copy-file f new-f)
                        (delete-file-if-exists f)))
360
                :collect new-f)
361 362
          files)))

363 364 365 366
  ;; DEPRECATED. Apparently, some users of ECL, MKCL and ABCL may still be using it;
  ;; but at the very least, this function should be renamed, and/or
  ;; some way of specifying the output directory should be provided.
  ;; As is, it is not such a useful interface.
367 368 369
  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    (declare (ignore force verbose version))
    (apply #'operate 'deliver-asd-op system args)))
370 371

;;;
372
;;; LOAD-BUNDLE-OP
373
;;;
374
;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
375
;;;
376
(with-upgradability ()
377
  (defmethod component-depends-on ((o load-bundle-op) (c system))
378
    `((,o ,@(component-sideway-dependencies c))
379
      (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
380
      ,@(call-next-method)))
381

382
  (defmethod input-files ((o load-bundle-op) (c system))
383
    (when (user-system-p c)
384
      (output-files (find-operation o 'compile-bundle-op) c)))
385

386
  (defmethod perform ((o load-bundle-op) (c system))
387 388
    (when (input-files o c)
      (perform-lisp-load-fasl o c)))
389

390
  (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
391
    (mark-operation-done (find-operation o 'load-op) c)))
392 393 394 395 396 397 398

;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;
399 400 401 402
(with-upgradability ()
  (defmethod trivial-system-p ((s system))
    (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
403
  (defmethod input-files ((o operation) (c compiled-file))
404
    (list (component-pathname c)))
405 406 407 408
  (defmethod perform ((o load-op) (c compiled-file))
    (perform-lisp-load-fasl o c))
  (defmethod perform ((o load-source-op) (c compiled-file))
    (perform (find-operation o 'load-op) c))
409
  (defmethod perform ((o operation) (c compiled-file))
410
    nil))
411 412 413 414

;;;
;;; Pre-built systems
;;;
415 416 417
(with-upgradability ()
  (defmethod trivial-system-p ((s prebuilt-system))
    t)
418

419
  (defmethod perform ((o link-op) (c prebuilt-system))
420
    nil)
421

422
  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
423
    nil)
424

425
  (defmethod perform ((o lib-op) (c prebuilt-system))
426 427
    nil)

428
  (defmethod perform ((o dll-op) (c prebuilt-system))
429
    nil)
430 431

  (defmethod component-depends-on ((o gather-op) (c prebuilt-system))
432 433 434
    nil)

  (defmethod output-files ((o lib-op) (c prebuilt-system))
435
    (values (list (prebuilt-system-static-library c)) t)))
436

437

438 439 440
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
441
(with-upgradability ()
442
  (defmethod output-files ((o deliver-asd-op) (s system))
443 444 445
    (list (make-pathname :name (component-name s) :type "asd"
                         :defaults (component-pathname s))))

446
  (defmethod perform ((o deliver-asd-op) (s system))
447 448 449
    (let* ((inputs (input-files o s))
           (fasl (first inputs))
           (library (second inputs))
450
           (asd (first (output-files o s)))
451
           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
452
           (version (component-version s))
453 454 455 456 457 458 459
           (dependencies
             (if (operation-monolithic-p o)
                 (remove-if-not 'builtin-system-p
                                (required-components s :component-type 'system
                                                       :keep-operation 'load-op))
                 (while-collecting (x) ;; resolve the sideway-dependencies of s
                   (map-direct-dependencies
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
460
                    t 'load-op s
461 462 463 464 465 466 467 468
                    #'(lambda (o c)
                        (when (and (typep o 'load-op) (typep c 'system))
                          (x c)))))))
           (depends-on (mapcar 'coerce-name dependencies)))
      (when (pathname-equal asd (system-source-file s))
        (cerror "overwrite the asd file"
                "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
                (cons o s) asd))
469 470
      (with-open-file (s asd :direction :output :if-exists :supersede
                             :if-does-not-exist :create)
471 472 473
        (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
                (operation-monolithic-p o) name)
        (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
474 475 476 477 478
                (lisp-implementation-type)
                (lisp-implementation-version)
                (software-type)
                (machine-type)
                (software-version))
479
        (let ((*package* (find-package :asdf-user)))
480
          (pprint `(defsystem ,name
481
                     :class prebuilt-system
482
                     :version ,version
483
                     :depends-on ,depends-on
484
                     :components ((:compiled-file ,(pathname-name fasl)))
485 486 487
                     ,@(when library `(:lib ,(file-namestring library))))
                  s)
          (terpri s)))))
488

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
489
  #-(or clasp ecl mkcl)
490
  (defmethod perform ((o basic-compile-bundle-op) (c system))
491
    (let* ((input-files (input-files o c))
492 493
           (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
           (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
494 495
           (output-files (output-files o c))
           (output-file (first output-files)))
496
      (assert (eq (not input-files) (not output-files)))
497 498
      (when input-files
        (when non-fasl-files
499
          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
500
                 (implementation-type) non-fasl-files))
501 502
        (when (or (prologue-code o) (epilogue-code o)
                  (prologue-code c) (epilogue-code c))
503 504 505 506 507 508
          (error "prologue-code and epilogue-code are not supported on ~A"
                 (implementation-type)))
        (with-staging-pathname (output-file)
          (combine-fasls fasl-files output-file)))))

  (defmethod input-files ((o load-op) (s precompiled-system))
509
    (bundle-output-files (find-operation o 'compile-bundle-op) s))
510

511 512 513
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

514
  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
515
    #+xcl (declare (ignorable o))
516 517
    `((load-op ,s) ,@(call-next-method))))

518
#| ;; Example use:
519 520 521 522
(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
(asdf:load-system :precompiled-asdf-utils)
|#

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
523
#+(or clasp ecl mkcl)
524
(with-upgradability ()
525

526 527
  #+ecl ;; doesn't work on clasp or mkcl (yet?).
  (unless (use-ecl-byte-compiler-p)
528
    (setf *load-system-operation* 'load-bundle-op))
529

530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546
  (defun system-module-pathname (module)
    (let ((name (coerce-name module)))
      (some
       #'probe-file
       (list
        #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
        #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
        #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
        #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
        #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))

  (defun make-library-system (name &optional (pathname (system-module-pathname name)))
    "Creates a prebuilt-system if PATHNAME isn't NIL."
    (when pathname
      (make-instance 'prebuilt-system
                     :name (coerce-name name)
                     :static-library (resolve-symlinks* pathname))))
547 548 549

  (defmethod component-depends-on :around ((o image-op) (c system))
    (destructuring-bind ((lib-op . deps)) (call-next-method)
550
      (labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))
551 552 553 554 555 556 557 558 559 560
               (linkable-system (x)
		 (unless (has-it-p x)
		   (list
		    (if (and (system-source-directory x)
			     #+mkcl ;; avoid bug in mkcl 1.1.10
			     (let ((s (find-system x)))
			       (or (not (typep s 'prebuilt-system))
				   (file-exists-p (prebuilt-system-static-library s)))))
			(find-system x)
			(make-library-system x))))))
561
        `((,lib-op
562 563 564 565
           ,@(unless (no-uiop c)
               (append (linkable-system "cmp")
                       (or (linkable-system "uiop")
                           (linkable-system "asdf"))))
566 567
           ,@deps)))))

568
  (defmethod perform ((o link-op) (c system))
569 570 571
    (let* ((object-files (input-files o c))
           (output (output-files o c))
           (bundle (first output))
572
           (programp (typep o 'program-op))
573
           (kind (bundle-type o)))
574
      (when output
575
        (apply 'create-image
576 577 578 579
               bundle (append
                       (when programp (prefix-lisp-object-files c))
                       object-files
                       (when programp (postfix-lisp-object-files c)))
580
               :kind kind
581 582
               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
583 584
               :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
               :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
585
               :no-uiop (no-uiop c)
586
               (when programp `(:entry-point ,(component-entry-point c))))))))