bundle.lisp 27.7 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/operation
8
   :asdf/find-component ;; used by ECL
9
   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
10
  (:export
11
   #:bundle-op #:bundle-type #:program-system
12
   #:bundle-system #:bundle-pathname-type #:direct-dependency-files
13
   #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
14 15
   #:basic-compile-bundle-op #:prepare-bundle-op
   #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
16 17
   #:lib-op #:monolithic-lib-op
   #:dll-op #:monolithic-dll-op
18 19
   #:deliver-asd-op #:monolithic-deliver-asd-op
   #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
20
   #:user-system-p #:user-system #:trivial-system-p
21
   #:prologue-code #:epilogue-code #:static-library))
22 23
(in-package :asdf/bundle)

24
(with-upgradability ()
25
  (defclass bundle-op (operation)
26 27 28
    ;; NB: use of instance-allocated slots for operations is DEPRECATED
    ;; and only supported in a temporary fashion for backward compatibility.
    ;; Supported replacement: Define slots on program-system instead.
29
    ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class))
30
    (:documentation "base class for operations that bundle outputs from multiple components"))
31

32 33 34 35 36
  (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
37
itself."))
38

39
  (defclass monolithic-bundle-op (bundle-op monolithic-op)
40 41
    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
    ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
42
    ((prologue-code :initform nil :accessor prologue-code)
43 44
     (epilogue-code :initform nil :accessor epilogue-code))
    (:documentation "operations that are both monolithic-op and bundle-op"))
45

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

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

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

71 72
  (defclass gather-operation (bundle-op)
    ((gather-operation :initform nil :allocation :class :reader gather-operation)
73
     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
74 75 76 77 78
    (:documentation "Abstract operation for gathering many input files from a system"))

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

79
  ;; Dependencies of a gather-op are the actions of the dependent operation
80 81 82 83 84
  ;; for all the (sorted) required components for loading the system.
  ;; Monolithic operations typically use lib-op as the dependent operation,
  ;; and all system-level dependencies as required components.
  ;; Non-monolithic operations typically use compile-op as the dependent operation,
  ;; and all transitive sub-components as required components (excluding other systems).
85
  (defmethod component-depends-on ((o gather-operation) (s system))
86
    (let* ((mono (operation-monolithic-p o))
87 88 89 90 91 92 93
           (go (make-operation (or (gather-operation o) 'compile-op)))
           (bundle-p (typep go 'bundle-op))
           ;; In a non-mono operation, don't recurse to other systems.
           ;; In a mono operation gathering bundles, don't recurse inside systems.
           (component-type (if mono (if bundle-p 'system t) '(not system)))
           ;; In the end, only keep system bundles or non-system bundles, depending.
           (keep-component (if bundle-p 'system '(not system)))
94
           (deps
95 96 97 98 99 100
            ;; Required-components only looks at the dependencies of an action, excluding the action
            ;; itself, so it may be safely used by an action recursing on its dependencies (which
            ;; may or may not be an overdesigned API, since in practice we never use it that way).
            ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
            ;; cleaner, we will miss the load-op on the requested system itself, which doesn't
            ;; matter for a regular system, but matters, a lot, for a package-inferred-system.
101
            ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
102
            ;; for our needs of gathering all the files we want to include in a bundle.
103
            ;; Note that we use basic-compile-op rather than compile-op so it will still work on
104
            ;; systems that would somehow load dependencies with load-bundle-op.
105
            (required-components
106
             s :other-systems mono :component-type component-type :keep-component keep-component
107
             :goal-operation 'load-op :keep-operation 'basic-compile-op)))
108
      `((,go ,@deps) ,@(call-next-method))))
109

110
  ;; Create a single fasl for the entire library
111
  (defclass basic-compile-bundle-op (bundle-op basic-compile-op)
112 113
    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
                  :allocation :class)
114
     (bundle-type :initform :fasb :allocation :class))
115
    (:documentation "Base class for compiling into a bundle"))
116

117
  ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
118
  (defclass prepare-bundle-op (sideway-operation)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
119 120
    ((sideway-operation
      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
121 122
      :allocation :class))
    (:documentation "Operation class for loading the bundles of a system's dependencies"))
123

124
  (defclass lib-op (link-op gather-operation non-propagating-operation)
125 126
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :lib :allocation :class))
127 128 129 130 131
    (: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.
132
On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
133 134
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."))
135

136
  ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
137
  ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
138 139 140
  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
                                                       #+(or clasp ecl mkcl) link-op)
    ((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
141 142 143 144
    (: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."))
145

146
  (defclass load-bundle-op (basic-load-op selfward-operation)
147 148 149 150 151
    ((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."))
152 153

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

158
  (defclass dll-op (link-op gather-operation non-propagating-operation)
159 160
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :dll :allocation :class))
161 162
    (: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."))
163

164
  (defclass deliver-asd-op (basic-compile-op selfward-operation)
165 166 167 168 169
    ((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))
170
    (:documentation "produce an asd file for delivering the system as a single fasl"))
171 172


173
  (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
174
    ((selfward-operation
175 176
      ;; 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
177 178
      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
      :allocation :class))
179 180
    (:documentation "produce fasl and asd files for combined system and dependencies."))

181
  (defclass monolithic-compile-bundle-op
182
      (basic-compile-bundle-op monolithic-bundle-op
183
       #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
184
    ()
185
    (:documentation "Create a single fasl for the system and its dependencies."))
186

187
  (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
188 189 190
    ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
    (:documentation "Load a single fasl for the system and its dependencies."))

191
  (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation)
192
    ((gather-type :initform :object :allocation :class))
193 194
    (: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."))
195

196
  (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation)
197
    ((gather-type :initform :object :allocation :class))
198 199
    (: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"))
200

201
  (defclass image-op (monolithic-bundle-op selfward-operation
202
                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
203
    ((bundle-type :initform :image :allocation :class)
204
     (gather-operation :initform 'lib-op :allocation :class)
205
     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
206
     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
207 208 209
    (:documentation "create an image file from the system and its dependencies"))

  (defclass program-op (image-op)
210
    ((bundle-type :initform :program :allocation :class))
211
    (:documentation "create an executable file from the system and its dependencies"))
212

213
  ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
214 215
  (defun bundle-pathname-type (bundle-type)
    (etypecase bundle-type
216 217 218 219 220
      ((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
221 222
       (compile-file-type)) ; on image-based platforms, used as input and output
      ((eql :fasb) ;; the type of a fasl
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
       #-(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")))))
241

242
  ;; Compute the output-files for a given bundle action
243
  (defun bundle-output-files (o c)
244 245 246 247
    (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)
248 249 250 251 252 253 254 255
                        (let ((suffix
                               (unless (typep o 'program-op)
                                 ;; "." is no good separator for Logical Pathnames, so we use "--"
                                 (if (operation-monolithic-p o)
                                     "--all-systems"
                                     ;; These use a different type .fasb or .a instead of .fasl
                                     #-(or clasp ecl mkcl) "--system"))))
                          (format nil "~A~@[~A~]" (component-name c) suffix))))
256 257
              (type (bundle-pathname-type bundle-type)))
          (values (list (subpathname (component-pathname c) name :type type))
258 259 260 261
                  (eq (class-of o) (coerce-class (component-build-operation c)
                                                 :package :asdf/interface
                                                 :super 'operation
                                                 :error nil)))))))
262 263 264 265

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

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
266
  #-(or clasp ecl mkcl)
267 268 269 270 271
  (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)))))
272 273

  (defclass compiled-file (file-component)
274 275 276 277
    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))
    (:documentation "Class for a file that is already compiled,
e.g. as part of the implementation, of an outer build system that calls into ASDF,
or of opaque libraries shipped along the source code."))
278 279

  (defclass precompiled-system (system)
280
    ((build-pathname :initarg :fasb :initarg :fasl))
281
    (:documentation "Class For a system that is delivered as a precompiled fasl"))
282 283 284

  (defclass prebuilt-system (system)
    ((build-pathname :initarg :static-library :initarg :lib
285
                     :accessor prebuilt-system-static-library))
286
    (:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
287

288 289 290 291 292 293 294 295 296

;;;
;;; 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.
;;;
297
(when-upgrading (:version "3.2.0")
298 299 300
  ;; Cancel any previously defined method
  (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
    (declare (ignore initargs))))
301

302
(with-upgradability ()
303
  (defgeneric trivial-system-p (component))
304 305 306 307

  (defun user-system-p (s)
    (and (typep s 'system)
         (not (builtin-system-p s))
308
         (not (trivial-system-p s)))))
309

310
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
311
  (deftype user-system () '(and system (satisfies user-system-p))))
312 313 314 315 316 317 318 319 320

;;;
;;; 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
;;;
321 322
(with-upgradability ()
  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
323 324
    ;; This function selects output files from direct dependencies;
    ;; your component-depends-on method must gather the correct dependencies in the correct order.
325 326
    (while-collecting (collect)
      (map-direct-dependencies
327 328 329
       o c #'(lambda (sub-o sub-c)
               (loop :for f :in (funcall key sub-o sub-c)
                 :when (funcall test f) :do (collect f))))))
330

331
  (defun pathname-type-equal-function (type)
332
    #'(lambda (p) (equalp (pathname-type p) type)))
333

334
  (defmethod input-files ((o gather-operation) (c system))
335
    (unless (eq (bundle-type o) :no-output-file)
336 337 338
      (direct-dependency-files
       o c :key 'output-files
           :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
339

340
  ;; Find the operation that produces a given bundle-type
341 342 343 344 345 346
  (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))
347
      ((:fasb)
348
       (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
349 350
      ((:image)
       'image-op)
351
      ((:program)
352
       'program-op))))
353 354

;;;
355
;;; LOAD-BUNDLE-OP
356
;;;
357
;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
358
;;;
359
(with-upgradability ()
360
  (defmethod component-depends-on ((o load-bundle-op) (c system))
361
    `((,o ,@(component-sideway-dependencies c))
362
      (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
363
      ,@(call-next-method)))
364

365
  (defmethod input-files ((o load-bundle-op) (c system))
366
    (when (user-system-p c)
367
      (output-files (find-operation o 'compile-bundle-op) c)))
368

369
  (defmethod perform ((o load-bundle-op) (c system))
370 371
    (when (input-files o c)
      (perform-lisp-load-fasl o c)))
372

373
  (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
374
    (mark-operation-done (find-operation o 'load-op) c)))
375 376 377 378 379 380 381

;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;
382 383 384 385
(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
386
  (defmethod input-files ((o operation) (c compiled-file))
387
    (list (component-pathname c)))
388 389 390 391
  (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))
392
  (defmethod perform ((o operation) (c compiled-file))
393
    nil))
394 395 396 397

;;;
;;; Pre-built systems
;;;
398 399 400
(with-upgradability ()
  (defmethod trivial-system-p ((s prebuilt-system))
    t)
401

402
  (defmethod perform ((o link-op) (c prebuilt-system))
403
    nil)
404

405
  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
406
    nil)
407

408
  (defmethod perform ((o lib-op) (c prebuilt-system))
409 410
    nil)

411
  (defmethod perform ((o dll-op) (c prebuilt-system))
412
    nil)
413

414
  (defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
415 416 417
    nil)

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

420

421 422 423
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
424
(with-upgradability ()
425
  (defmethod output-files ((o deliver-asd-op) (s system))
426 427 428
    (list (make-pathname :name (component-name s) :type "asd"
                         :defaults (component-pathname s))))

429
  (defmethod perform ((o deliver-asd-op) (s system))
430 431 432
    (let* ((inputs (input-files o s))
           (fasl (first inputs))
           (library (second inputs))
433
           (asd (first (output-files o s)))
434
           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
435
           (version (component-version s))
436 437
           (dependencies
             (if (operation-monolithic-p o)
438
                 ;; We want only dependencies, and we use basic-load-op rather than load-op so that
439
                 ;; this will keep working on systems that load dependencies with load-bundle-op
440 441
                 (remove-if-not 'builtin-system-p
                                (required-components s :component-type 'system
442
                                                       :keep-operation 'basic-load-op))
443 444
                 (while-collecting (x) ;; resolve the sideway-dependencies of s
                   (map-direct-dependencies
445
                    'load-op s
446 447 448 449 450 451
                    #'(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"
452 453
                "~/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."
454
                (cons o s) asd))
455 456
      (with-open-file (s asd :direction :output :if-exists :supersede
                             :if-does-not-exist :create)
457 458 459
        (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~%"
460 461 462 463 464
                (lisp-implementation-type)
                (lisp-implementation-version)
                (software-type)
                (machine-type)
                (software-version))
465
        (let ((*package* (find-package :asdf-user)))
466
          (pprint `(defsystem ,name
467
                     :class prebuilt-system
468
                     :version ,version
469
                     :depends-on ,depends-on
470
                     :components ((:compiled-file ,(pathname-name fasl)))
471 472 473
                     ,@(when library `(:lib ,(file-namestring library))))
                  s)
          (terpri s)))))
474

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
475
  #-(or clasp ecl mkcl)
476
  (defmethod perform ((o basic-compile-bundle-op) (c system))
477
    (let* ((input-files (input-files o c))
478 479
           (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))
480 481
           (output-files (output-files o c))
           (output-file (first output-files)))
482
      (assert (eq (not input-files) (not output-files)))
483 484
      (when input-files
        (when non-fasl-files
485
          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
486
                 (implementation-type) non-fasl-files))
487
        (when (or (prologue-code c) (epilogue-code c))
488 489 490 491 492 493
          (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))
494
    (bundle-output-files (find-operation o 'compile-bundle-op) s))
495

496 497 498
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

499
  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
500 501
    `((load-op ,s) ,@(call-next-method))))

502
#| ;; Example use:
503 504 505 506
(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
507
#+(or clasp ecl mkcl)
508
(with-upgradability ()
509 510 511
  (defun system-module-pathname (module)
    (let ((name (coerce-name module)))
      (some
512
       'file-exists-p
513 514 515
       (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)
516
        #+ecl (compile-file-pathname (make-pathname :name (strcat "lib" name) :defaults "sys:") :type :lib)
517 518 519 520
        #+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;")))))

521
  (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
522 523 524 525 526
    "Creates a prebuilt-system if PATHNAME isn't NIL."
    (when pathname
      (make-instance 'prebuilt-system
                     :name (coerce-name name)
                     :static-library (resolve-symlinks* pathname))))
527

528 529
  (defun linkable-system (x)
    (or (if-let (s (find-system x))
530
          (and (output-files 'lib-op s) s))
531 532 533
        (if-let (p (system-module-pathname (coerce-name x)))
          (make-prebuilt-system x p))))

534
  (defmethod component-depends-on :around ((o image-op) (c system))
535 536 537 538 539 540 541 542 543
    (let* ((next (call-next-method))
           (deps (make-hash-table :test 'equal))
           (linkable (loop* :for (do . dcs) :in next :collect
                       (cons do
                             (loop :for dc :in dcs
                               :for dep = (and dc (resolve-dependency-spec c dc))
                               :when dep
                               :do (setf (gethash (coerce-name (component-system dep)) deps) t)
                               :collect (or (and (typep dep 'system) (linkable-system dep)) dep))))))
544
        `((lib-op
545
           ,@(unless (no-uiop c)
546
               (list (linkable-system "cmp")
547 548
                     (unless (or (and (gethash "uiop" deps) (linkable-system "uiop"))
                                 (and (gethash "asdf" deps) (linkable-system "asdf")))
549 550 551 552
                       (or (linkable-system "uiop")
                           (linkable-system "asdf")
                           "asdf")))))
          ,@linkable)))
553

554
  (defmethod perform ((o link-op) (c system))
555 556 557
    (let* ((object-files (input-files o c))
           (output (output-files o c))
           (bundle (first output))
558
           (programp (typep o 'program-op))
559
           (kind (bundle-type o)))
560
      (when output
561
        (apply 'create-image
562 563 564 565
               bundle (append
                       (when programp (prefix-lisp-object-files c))
                       object-files
                       (when programp (postfix-lisp-object-files c)))
566
               :kind kind
567 568 569 570
               :prologue-code (when programp (prologue-code c))
               :epilogue-code (when programp (epilogue-code c))
               :build-args (when programp (extra-build-args c))
               :extra-object-files (when programp (extra-object-files c))
571
               :no-uiop (no-uiop c)
572
               (when programp `(:entry-point ,(component-entry-point c))))))))