bundle.lisp 27.9 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
    (:documentation "base class for operations that bundle outputs from multiple components"))
27
  (defgeneric bundle-type (bundle-op))
28

29
30
31
32
33
  (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
34
itself."))
35

36
  (defclass monolithic-bundle-op (bundle-op monolithic-op)
37
38
    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
    ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
39
    ((prologue-code :initform nil :accessor prologue-code)
40
41
     (epilogue-code :initform nil :accessor epilogue-code))
    (:documentation "operations that are both monolithic-op and bundle-op"))
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
59
60
61
62
63
  (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)
64
65
66
67

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

68
  (defclass gather-operation (bundle-op) ()
69
    (:documentation "Abstract operation for gathering many input files from a system"))
70
71
72
  (defgeneric gather-operation (gather-operation))
  (defmethod gather-operation ((o gather-operation)) nil)
  (defgeneric gather-type (gather-operation))
73
74
75
76

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

77
  ;; Dependencies of a gather-op are the actions of the dependent operation
78
79
80
81
82
  ;; 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).
83
  (defmethod component-depends-on ((o gather-operation) (s system))
84
    (let* ((mono (operation-monolithic-p o))
85
86
87
88
89
90
91
           (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)))
92
           (deps
93
94
95
96
97
98
            ;; 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.
99
            ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
100
            ;; for our needs of gathering all the files we want to include in a bundle.
101
            ;; Note that we use basic-compile-op rather than compile-op so it will still work on
102
            ;; systems that would somehow load dependencies with load-bundle-op.
103
            (required-components
104
             s :other-systems mono :component-type component-type :keep-component keep-component
105
             :goal-operation 'load-op :keep-operation 'basic-compile-op)))
106
      `((,go ,@deps) ,@(call-next-method))))
107

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

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

123
  (defclass lib-op (link-op gather-operation non-propagating-operation) ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
124
125
126
127
128
    (: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.
129
On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
130
131
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."))
132
133
  (defmethod bundle-type ((o lib-op)) :lib)
  (defmethod gather-type ((o lib-op)) :object)
134

135
  ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
136
  ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
137
138
139
  (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))
140
141
142
143
    (: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."))
144

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

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

157
  (defclass dll-op (link-op gather-operation non-propagating-operation) ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
158
159
    (: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."))
160
161
  (defmethod bundle-type ((o dll-op)) :dll)
  (defmethod gather-type ((o dll-op)) :object)
162

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


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

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

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

190
  (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
191
192
    (: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."))
193

194
  (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
195
196
    (: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"))
197

198
  (defclass image-op (monolithic-bundle-op selfward-operation
199
                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
200
    ((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
201
    (:documentation "create an image file from the system and its dependencies"))
202
203
204
  (defmethod bundle-type ((o image-op)) :image)
  #+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op)
  #+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library)
205

206
  (defclass program-op (image-op) ()
207
    (:documentation "create an executable file from the system and its dependencies"))
208
  (defmethod bundle-type ((o program-op)) :program)
209

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

239
  ;; Compute the output-files for a given bundle action
240
  (defun bundle-output-files (o c)
241
242
243
244
    (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)
245
246
247
248
249
250
251
252
                        (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))))
253
254
              (type (bundle-pathname-type bundle-type)))
          (values (list (subpathname (component-pathname c) name :type type))
255
256
257
258
                  (eq (class-of o) (coerce-class (component-build-operation c)
                                                 :package :asdf/interface
                                                 :super 'operation
                                                 :error nil)))))))
259
260
261
262

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

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

  (defclass compiled-file (file-component)
271
272
273
274
    ((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."))
275
276

  (defclass precompiled-system (system)
277
    ((build-pathname :initarg :fasb :initarg :fasl))
278
    (:documentation "Class For a system that is delivered as a precompiled fasl"))
279
280
281

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

285
286
287
288
289
290
291
292
293

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

299
(with-upgradability ()
300
  (defgeneric trivial-system-p (component))
301
302
303
304

  (defun user-system-p (s)
    (and (typep s 'system)
         (not (builtin-system-p s))
305
         (not (trivial-system-p s)))))
306

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

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

328
  (defun pathname-type-equal-function (type)
329
    #'(lambda (p) (equalp (pathname-type p) type)))
330

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

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

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

362
  (defmethod input-files ((o load-bundle-op) (c system))
363
    (when (user-system-p c)
364
      (output-files (find-operation o 'compile-bundle-op) c)))
365

366
  (defmethod perform ((o load-bundle-op) (c system))
367
368
    (when (input-files o c)
      (perform-lisp-load-fasl o c)))
369

370
  (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
371
    (mark-operation-done (find-operation o 'load-op) c)))
372
373
374
375
376
377
378

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

;;;
;;; Pre-built systems
;;;
395
396
397
(with-upgradability ()
  (defmethod trivial-system-p ((s prebuilt-system))
    t)
398

399
  (defmethod perform ((o link-op) (c prebuilt-system))
400
    nil)
401

402
  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
403
    nil)
404

405
  (defmethod perform ((o lib-op) (c prebuilt-system))
406
407
    nil)

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

411
  (defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
412
413
414
    nil)

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

417

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

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

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

493
494
495
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

496
  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
497
498
    `((load-op ,s) ,@(call-next-method))))

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

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

525
  (defun linkable-system (x)
526
527
    (or ;; If the system is available as source, use it.
        (if-let (s (find-system x))
528
          (and (output-files 'lib-op s) s))
529
530
531
        ;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that,
        ;; then use the asdf/driver system instead of
        ;; the UIOP that was disabled by check-not-old-asdf-system.
Robert P. Goldm an's avatar
Robert P. Goldm an committed
532
533
534
        (if-let (s (and (equal (coerce-name x) "uiop")
                        (output-files 'lib-op "asdf")
                        (find-system "asdf/driver")))
535
536
          (and (output-files 'lib-op s) s))
        ;; If there was no source upgrade, look for modules provided by the implementation.
537
538
539
        (if-let (p (system-module-pathname (coerce-name x)))
          (make-prebuilt-system x p))))

540
  (defmethod component-depends-on :around ((o image-op) (c system))
541
542
543
544
545
546
547
548
549
    (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))))))
550
        `((lib-op
551
           ,@(unless (no-uiop c)
552
               (list (linkable-system "cmp")
553
554
                     (unless (or (and (gethash "uiop" deps) (linkable-system "uiop"))
                                 (and (gethash "asdf" deps) (linkable-system "asdf")))
555
556
557
558
                       (or (linkable-system "uiop")
                           (linkable-system "asdf")
                           "asdf")))))
          ,@linkable)))
559

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
575
576
               :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))
577
               :no-uiop (no-uiop c)
578
               (when programp `(:entry-point ,(component-entry-point c))))))))