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 (type-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
310
311
  (defun pathname-type-equal-function (type)
    #'(lambda (p) (equal (pathname-type p) type)))

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
  ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it?
332
333
334
335
336
337
  (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)))
338
                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
339
340
341
342
343
344
345
                               (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)
346
                             (member operation-name '(:program :image))))
347
348
349
350
351
352
353
          (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)
                :do (rename-file-overwriting-target f new-f)
                :collect new-f)
354
355
356
357
358
359
          files)))

  ;; DEPRECATED. Does anyone use this?
  (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)))
360
361

;;;
362
;;; LOAD-BUNDLE-OP
363
;;;
364
;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
365
;;;
366
(with-upgradability ()
367
  (defmethod component-depends-on ((o load-bundle-op) (c system))
368
    `((,o ,@(component-sideway-dependencies c))
369
      (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
370
      ,@(call-next-method)))
371

372
  (defmethod input-files ((o load-bundle-op) (c system))
373
    (when (user-system-p c)
374
      (output-files (find-operation o 'compile-bundle-op) c)))
375

376
  (defmethod perform ((o load-bundle-op) (c system))
377
378
    (when (input-files o c)
      (perform-lisp-load-fasl o c)))
379

380
  (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
381
    (mark-operation-done (find-operation o 'load-op) c)))
382
383
384
385
386
387
388

;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;
389
390
391
392
(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
393
  (defmethod input-files ((o operation) (c compiled-file))
394
    (list (component-pathname c)))
395
396
397
398
  (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))
399
  (defmethod perform ((o operation) (c compiled-file))
400
    nil))
401
402
403
404

;;;
;;; Pre-built systems
;;;
405
406
407
(with-upgradability ()
  (defmethod trivial-system-p ((s prebuilt-system))
    t)
408

409
  (defmethod perform ((o link-op) (c prebuilt-system))
410
    nil)
411

412
  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
413
    nil)
414

415
  (defmethod perform ((o lib-op) (c prebuilt-system))
416
417
    nil)

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

  (defmethod component-depends-on ((o gather-op) (c prebuilt-system))
422
423
424
    nil)

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

427

428
429
430
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
431
(with-upgradability ()
432
  (defmethod output-files ((o deliver-asd-op) (s system))
433
434
435
    (list (make-pathname :name (component-name s) :type "asd"
                         :defaults (component-pathname s))))

436
  (defmethod perform ((o deliver-asd-op) (s system))
437
438
439
    (let* ((inputs (input-files o s))
           (fasl (first inputs))
           (library (second inputs))
440
           (asd (first (output-files o s)))
441
           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
442
           (version (component-version s))
443
444
445
446
447
448
449
           (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
450
                    t 'load-op s
451
452
453
454
455
456
457
458
                    #'(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))
459
460
      (with-open-file (s asd :direction :output :if-exists :supersede
                             :if-does-not-exist :create)
461
462
463
        (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~%"
464
465
466
467
468
                (lisp-implementation-type)
                (lisp-implementation-version)
                (software-type)
                (machine-type)
                (software-version))
469
        (let ((*package* (find-package :asdf-user)))
470
          (pprint `(defsystem ,name
471
                     :class prebuilt-system
472
                     :version ,version
473
                     :depends-on ,depends-on
474
                     :components ((:compiled-file ,(pathname-name fasl)))
475
476
477
                     ,@(when library `(:lib ,(file-namestring library))))
                  s)
          (terpri s)))))
478

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

501
502
503
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

504
  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
505
    #+xcl (declare (ignorable o))
506
507
    `((load-op ,s) ,@(call-next-method))))

508
#| ;; Example use:
509
510
511
512
(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
513
#+(or clasp ecl mkcl)
514
(with-upgradability ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
515
516
  ;; I think that Juanjo intended for this to be, but it was disabled before 3.1
  ;; due to implementation bugs in ECL and MKCL that seem to have been fixed since
517
  ;; -- see for ECL test-xach-update-bug.script and test-bundle.script,
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
518
519
  ;; and for MKCL test-logical-pathname.script.
  ;; We should probably reenable these after consulting with ECL and MKCL maintainers.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
520
  ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
521
  ;;  (setf *load-system-operation* 'load-bundle-op))
522

523
  (defun uiop-library-pathname ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
524
    #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
525
526
527
528
    #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
              (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop"))

529
  (defun asdf-library-pathname ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
530
    #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
531
532
    #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
              (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
533
534
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))

535
  (defun compiler-library-pathname ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
536
    #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
537
538
539
    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))

540
  (defun make-library-system (name pathname)
541
542
    (make-instance 'prebuilt-system
                   :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
543
544
545
546
547

  (defmethod component-depends-on :around ((o image-op) (c system))
    (destructuring-bind ((lib-op . deps)) (call-next-method)
      (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
        `((,lib-op
548
549
550
551
           ,@(unless (or (no-uiop c) (has-it-p "cmp"))
               `(,(make-library-system
                   "cmp" (compiler-library-pathname))))
           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
552
553
554
555
556
557
               (cond
                 ((system-source-directory :uiop) `(,(find-system :uiop)))
                 ((system-source-directory :asdf) `(,(find-system :asdf)))
                 (t `(,@(if-let (uiop (uiop-library-pathname))
                          `(,(make-library-system "uiop" uiop)))
                      ,(make-library-system "asdf" (asdf-library-pathname))))))
558
559
           ,@deps)))))

560
  (defmethod perform ((o link-op) (c system))
561
562
563
    (let* ((object-files (input-files o c))
           (output (output-files o c))
           (bundle (first output))
564
           (programp (typep o 'program-op))
565
           (kind (bundle-type o)))
566
      (when output
567
        (apply 'create-image
568
569
570
571
               bundle (append
                       (when programp (prefix-lisp-object-files c))
                       object-files
                       (when programp (postfix-lisp-object-files c)))
572
               :kind kind
573
574
               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
575
576
               :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)))
577
               :no-uiop (no-uiop c)
578
               (when programp `(:entry-point ,(component-entry-point c))))))))