bundle.lisp 29.3 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
27
28
    ;; NB: use of instance-allocated slots for operations is DEPRECATED
    ;; and only supported in a temporary fashion for backward compatibility.
    ;; Supported replacement: Define slots on program-system instead.
29
    ((build-args :initarg :args :initform nil :accessor extra-build-args)
30
31
     (name-suffix :initarg :name-suffix :initform nil)
     (bundle-type :initform :no-output-file :reader bundle-type)
32
33
     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files))
    (:documentation "base class for operations that bundle outputs from multiple components"))
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
40
itself."))
41
42

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

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

63
64
  (defmethod prologue-code ((x t)) nil)
  (defmethod epilogue-code ((x t)) nil)
65
  (defmethod no-uiop ((x t)) nil)
66
67
68
69
  (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)
70
71
72
73
74

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

  (defclass gather-op (bundle-op)
75
    ;; TODO: rename the slot and reader gather-op to gather-operation
76
77
    ((gather-op :initform nil :allocation :class :reader gather-op)
     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
78
79
80
81
82
    (:documentation "Abstract operation for gathering many input files from a system"))

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

83
  ;; Dependencies of a gather-op are the actions of the dependent operation
84
85
86
87
88
  ;; 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).
89
90
91
92
93
94
95
96
97
98
99
  (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))))
100

101
  ;; Create a single fasl for the entire library
102
  (defclass basic-compile-bundle-op (bundle-op)
103
104
    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
                  :allocation :class)
105
106
     (bundle-type :initform :fasl :allocation :class))
    (:documentation "Base class for compiling into a bundle"))
107

108
  ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
109
  (defclass prepare-bundle-op (sideway-operation)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
110
111
    ((sideway-operation
      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
112
113
      :allocation :class))
    (:documentation "Operation class for loading the bundles of a system's dependencies"))
114
115

  (defclass lib-op (link-op gather-op non-propagating-operation)
116
117
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :lib :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
118
119
120
121
122
    (: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.
123
On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
124
125
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."))
126

127
  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
128
129
                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
    ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
130
131
132
133
134
                         :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."))
135

136
  (defclass load-bundle-op (basic-load-op selfward-operation)
137
138
139
140
141
    ((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."))
142
143

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

148
  (defclass dll-op (link-op gather-op non-propagating-operation)
149
150
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :dll :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
151
152
    (: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."))
153

154
  (defclass deliver-asd-op (basic-compile-op selfward-operation)
155
156
157
158
159
    ((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))
160
    (:documentation "produce an asd file for delivering the system as a single fasl"))
161
162


163
  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
164
    ((selfward-operation
165
166
      ;; 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
167
168
      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
      :allocation :class))
169
170
    (:documentation "produce fasl and asd files for combined system and dependencies."))

171
172
173
174
175
176
177
  (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))
178
    (:documentation "Create a single fasl for the system and its dependencies."))
179

180
181
182
183
  (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
184
185
  (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
186
187
    (: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."))
188

189
  (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
190
    ((gather-type :initform :static-library :allocation :class))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
191
192
    (: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"))
193

194
  (defclass image-op (monolithic-bundle-op selfward-operation
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
195
                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
196
    ((bundle-type :initform :image)
197
     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
198
     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
199
200
201
202
    (:documentation "create an image file from the system and its dependencies"))

  (defclass program-op (image-op)
    ((bundle-type :initform :program))
203
    (:documentation "create an executable file from the system and its dependencies"))
204

205
  ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
206
207
  (defun bundle-pathname-type (bundle-type)
    (etypecase bundle-type
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
      ((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")))))
231

232
  ;; Compute the output-files for a given bundle action
233
  (defun bundle-output-files (o c)
234
235
236
237
238
239
240
    (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))
241
242
243
244
                  (eq (class-of o) (coerce-class (component-build-operation c)
                                                 :package :asdf/interface
                                                 :super 'operation
                                                 :error nil)))))))
245
246
247
248

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

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
249
  #-(or clasp ecl mkcl)
250
251
252
253
254
  (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)))))
255
256

  (defclass compiled-file (file-component)
257
258
259
260
    ((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."))
261
262

  (defclass precompiled-system (system)
263
264
    ((build-pathname :initarg :fasl))
    (:documentation "Class For a system that is delivered as a precompiled fasl"))
265
266
267

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

271
272
273
274
275
276
277
278
279

;;;
;;; 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.
;;;
280
281
282
283
(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
284
    (declare (ignore initargs name-suffix))
285
    ;; TODO: make that class slots or methods, not instance slots
286
287
288
    (unless name-suffix-p
      (setf (slot-value instance 'name-suffix)
            (unless (typep instance 'program-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
289
290
              ;; "." is no good separator for Logical Pathnames, so we use "--"
              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
291
    (when (typep instance 'monolithic-bundle-op)
292
      (destructuring-bind (&key lisp-files prologue-code epilogue-code
293
294
                           &allow-other-keys)
          (operation-original-initargs instance)
295
296
        (setf (prologue-code instance) prologue-code
              (epilogue-code instance) epilogue-code)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
297
298
        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
299
    (setf (extra-build-args instance)
300
          (remove-plist-keys
301
302
           '(: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
303
           (operation-original-initargs instance))))
304
305
306
307
308
309

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

  (defun user-system-p (s)
    (and (typep s 'system)
         (not (builtin-system-p s))
310
         (not (trivial-system-p s)))))
311

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

;;;
;;; 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
;;;
323
324
(with-upgradability ()
  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
325
326
    ;; This function selects output files from direct dependencies;
    ;; your component-depends-on method must gather the correct dependencies in the correct order.
327
328
    (while-collecting (collect)
      (map-direct-dependencies
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
329
330
331
       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))))))
332

333
  (defun pathname-type-equal-function (type)
334
    #'(lambda (p) (equalp (pathname-type p) type)))
335

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

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

356
357
358
359
  ;; DEPRECATED. This is originally from asdf-ecl.lisp.
  ;; It must die, and so must any use of initargs in operation,
  ;; unless keys to the asdf-cache are substantially modified to accommodate for them.
  ;; Coordinate with the ECL maintainers to get them to stop using it.
360
  ;; SUPPORTED REPLACEMENT: Use program-op and program-system
361
362
363
364
365
366
  (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)))
367
                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
368
                               (system-relative-pathname system "asdf-output/")))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
369
           (operation (apply 'operate operation-name
370
371
372
373
374
                             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)
375
                             (member operation-name '(:program :image))))
376
377
378
379
380
          (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)
381
382
                :do (handler-case (rename-file-overwriting-target f new-f)
                      (file-error (c)
Elias Pipping's avatar
Elias Pipping committed
383
                        (declare (ignore c))
384
385
                        (copy-file f new-f)
                        (delete-file-if-exists f)))
386
                :collect new-f)
387
388
          files)))

389
390
391
392
  ;; DEPRECATED. Apparently, some users of ECL, MKCL and ABCL may still be using it;
  ;; but at the very least, this function should be renamed, and/or
  ;; some way of specifying the output directory should be provided.
  ;; As is, it is not such a useful interface.
393
394
  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    (declare (ignore force verbose version))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
395
    (apply 'operate 'deliver-asd-op system args)))
396
397

;;;
398
;;; LOAD-BUNDLE-OP
399
;;;
400
;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
401
;;;
402
(with-upgradability ()
403
  (defmethod component-depends-on ((o load-bundle-op) (c system))
404
    `((,o ,@(component-sideway-dependencies c))
405
      (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
406
      ,@(call-next-method)))
407

408
  (defmethod input-files ((o load-bundle-op) (c system))
409
    (when (user-system-p c)
410
      (output-files (find-operation o 'compile-bundle-op) c)))
411

412
  (defmethod perform ((o load-bundle-op) (c system))
413
414
    (when (input-files o c)
      (perform-lisp-load-fasl o c)))
415

416
  (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
417
    (mark-operation-done (find-operation o 'load-op) c)))
418
419
420
421
422
423
424

;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;
425
426
427
428
(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
429
  (defmethod input-files ((o operation) (c compiled-file))
430
    (list (component-pathname c)))
431
432
433
434
  (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))
435
  (defmethod perform ((o operation) (c compiled-file))
436
    nil))
437
438
439
440

;;;
;;; Pre-built systems
;;;
441
442
443
(with-upgradability ()
  (defmethod trivial-system-p ((s prebuilt-system))
    t)
444

445
  (defmethod perform ((o link-op) (c prebuilt-system))
446
    nil)
447

448
  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
449
    nil)
450

451
  (defmethod perform ((o lib-op) (c prebuilt-system))
452
453
    nil)

454
  (defmethod perform ((o dll-op) (c prebuilt-system))
455
    nil)
456
457

  (defmethod component-depends-on ((o gather-op) (c prebuilt-system))
458
459
460
    nil)

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

463

464
465
466
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
467
(with-upgradability ()
468
  (defmethod output-files ((o deliver-asd-op) (s system))
469
470
471
    (list (make-pathname :name (component-name s) :type "asd"
                         :defaults (component-pathname s))))

472
  (defmethod perform ((o deliver-asd-op) (s system))
473
474
475
    (let* ((inputs (input-files o s))
           (fasl (first inputs))
           (library (second inputs))
476
           (asd (first (output-files o s)))
477
           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
478
           (version (component-version s))
479
480
481
482
483
484
485
           (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
486
                    t 'load-op s
487
488
489
490
491
492
493
494
                    #'(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))
495
496
      (with-open-file (s asd :direction :output :if-exists :supersede
                             :if-does-not-exist :create)
497
498
499
        (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~%"
500
501
502
503
504
                (lisp-implementation-type)
                (lisp-implementation-version)
                (software-type)
                (machine-type)
                (software-version))
505
        (let ((*package* (find-package :asdf-user)))
506
          (pprint `(defsystem ,name
507
                     :class prebuilt-system
508
                     :version ,version
509
                     :depends-on ,depends-on
510
                     :components ((:compiled-file ,(pathname-name fasl)))
511
512
513
                     ,@(when library `(:lib ,(file-namestring library))))
                  s)
          (terpri s)))))
514

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
515
  #-(or clasp ecl mkcl)
516
  (defmethod perform ((o basic-compile-bundle-op) (c system))
517
    (let* ((input-files (input-files o c))
518
519
           (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))
520
521
           (output-files (output-files o c))
           (output-file (first output-files)))
522
      (assert (eq (not input-files) (not output-files)))
523
524
      (when input-files
        (when non-fasl-files
525
          (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
526
                 (implementation-type) non-fasl-files))
527
528
        (when (or (prologue-code o) (epilogue-code o)
                  (prologue-code c) (epilogue-code c))
529
530
531
532
533
534
          (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))
535
    (bundle-output-files (find-operation o 'compile-bundle-op) s))
536

537
538
539
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

540
  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
541
    #+xcl (declare (ignorable o))
542
543
    `((load-op ,s) ,@(call-next-method))))

544
#| ;; Example use:
545
546
547
548
(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
549
#+(or clasp ecl mkcl)
550
(with-upgradability ()
551

552
553
  #+ecl ;; doesn't work on clasp or mkcl (yet?).
  (unless (use-ecl-byte-compiler-p)
554
    (setf *load-system-operation* 'load-bundle-op))
555

556
557
558
  (defun system-module-pathname (module)
    (let ((name (coerce-name module)))
      (some
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
559
       'file-exists-p
560
561
562
563
564
565
566
       (list
        #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
        #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
        #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
        #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
        #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))

567
  (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
568
569
570
571
572
    "Creates a prebuilt-system if PATHNAME isn't NIL."
    (when pathname
      (make-instance 'prebuilt-system
                     :name (coerce-name name)
                     :static-library (resolve-symlinks* pathname))))
573
574
575

  (defmethod component-depends-on :around ((o image-op) (c system))
    (destructuring-bind ((lib-op . deps)) (call-next-method)
576
      (labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
577
               (ensure-linkable-system (x)
578
		 (unless (has-it-p x)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
579
580
581
582
                   (or (if-let (s (find-system x))
                         (and (system-source-directory x)
                              (list s)))
                       (if-let (p (system-module-pathname x))
583
                         (list (make-prebuilt-system x p)))))))
584
        `((,lib-op
585
           ,@(unless (no-uiop c)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
586
587
588
               (append (ensure-linkable-system "cmp")
                       (or (ensure-linkable-system "uiop")
                           (ensure-linkable-system "asdf"))))
589
590
           ,@deps)))))

591
  (defmethod perform ((o link-op) (c system))
592
593
594
    (let* ((object-files (input-files o c))
           (output (output-files o c))
           (bundle (first output))
595
           (programp (typep o 'program-op))
596
           (kind (bundle-type o)))
597
      (when output
598
        (apply 'create-image
599
600
601
602
               bundle (append
                       (when programp (prefix-lisp-object-files c))
                       object-files
                       (when programp (postfix-lisp-object-files c)))
603
               :kind kind
604
605
               :prologue-code (or (prologue-code o) (when programp (prologue-code c)))
               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
606
607
               :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)))
608
               :no-uiop (no-uiop c)
609
               (when programp `(:entry-point ,(component-entry-point c))))))))