bundle.lisp 27.6 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
   #:prologue-code #:epilogue-code #:static-library))
21
22
(in-package :asdf/bundle)

23
(with-upgradability ()
24
  (defclass bundle-op (operation)
25
26
27
    ;; 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.
28
    ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class))
29
    (:documentation "base class for operations that bundle outputs from multiple components"))
30

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

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

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

59
60
61
62
63
64
65
  (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)
66
67
68
69

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

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

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

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

109
  ;; Create a single fasl for the entire library
110
  (defclass basic-compile-bundle-op (bundle-op basic-compile-op)
111
112
    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
                  :allocation :class)
113
     (bundle-type :initform :fasb :allocation :class))
114
    (:documentation "Base class for compiling into a bundle"))
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)
124
125
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :lib :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
126
127
128
129
130
    (: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.
131
On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
132
133
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."))
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)
158
159
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :dll :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
160
161
    (: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."))
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)
191
    ((gather-type :initform :object :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
192
193
    (: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."))
194

195
  (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation)
196
    ((gather-type :initform :object :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
197
198
    (: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"))
199

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

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

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

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

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

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

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

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

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

287
288
289
290
291
292
293
294
295

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

419

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

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

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

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

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

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

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

527
528
529
530
531
532
  (defun linkable-system (x)
    (or (if-let (s (find-system x))
          (and (system-source-file x) s))
        (if-let (p (system-module-pathname (coerce-name x)))
          (make-prebuilt-system x p))))

533
  (defmethod component-depends-on :around ((o image-op) (c system))
534
535
536
537
538
539
540
541
542
    (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))))))
543
        `((lib-op
544
           ,@(unless (no-uiop c)
545
546
547
548
549
550
               (list (linkable-system "cmp")
                     (unless (or (gethash "uiop" deps) (gethash "asdf" deps))
                       (or (linkable-system "uiop")
                           (linkable-system "asdf")
                           "asdf")))))
          ,@linkable)))
551

552
  (defmethod perform ((o link-op) (c system))
553
554
555
    (let* ((object-files (input-files o c))
           (output (output-files o c))
           (bundle (first output))
556
           (programp (typep o 'program-op))
557
           (kind (bundle-type o)))
558
      (when output
559
        (apply 'create-image
560
561
562
563
               bundle (append
                       (when programp (prefix-lisp-object-files c))
                       object-files
                       (when programp (postfix-lisp-object-files c)))
564
               :kind kind
565
566
567
568
               :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))
569
               :no-uiop (no-uiop c)
570
               (when programp `(:entry-point ,(component-entry-point c))))))))