bundle.lisp 29.1 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
76
    ((gather-op :initform nil :allocation :class :reader gather-op)
     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
77
78
79
80
81
    (:documentation "Abstract operation for gathering many input files from a system"))

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

82
83
84
85
86
  ;; Dependencies of a gather-op are the actions of the dependent operation
  ;; (from gather-op reader, defaulting to lib-op or compile-op depending
  ;; on the operation being monolithic or not) for all the (sorted) required components
  ;; for loading the system, recursing either to other systems or sub-components
  ;; depending on it being monolithic or not.
87
88
89
90
91
92
93
94
95
96
97
  (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))))
98

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

  (defclass prebuilt-system (system)
    ((build-pathname :initarg :static-library :initarg :lib
266
267
                     :accessor prebuilt-system-static-library))
    (:documentation "Class for a system that comes precompiled with a static library file")))
268

269
270
271
272
273
274
275
276
277

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

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

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

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

;;;
;;; First we handle monolithic bundles.
;;; These are standalone systems which contain everything,
;;; including other ASDF systems required by the current one.
;;; A PROGRAM is always monolithic.
;;;
;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
;;;
321
322
(with-upgradability ()
  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
323
324
    ;; This function selects output files from direct dependencies;
    ;; your component-depends-on method must gather the correct dependencies in the correct order.
325
326
    (while-collecting (collect)
      (map-direct-dependencies
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
327
328
329
       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))))))
330

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

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

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

354
355
356
357
  ;; 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.
358
  ;; SUPPORTED REPLACEMENT: Use program-op and program-system
359
360
361
362
363
364
  (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)))
365
                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
366
                               (system-relative-pathname system "asdf-output/")))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
367
           (operation (apply 'operate operation-name
368
369
370
371
372
                             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)
373
                             (member operation-name '(:program :image))))
374
375
376
377
378
          (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)
379
380
                :do (handler-case (rename-file-overwriting-target f new-f)
                      (file-error (c)
Elias Pipping's avatar
Elias Pipping committed
381
                        (declare (ignore c))
382
383
                        (copy-file f new-f)
                        (delete-file-if-exists f)))
384
                :collect new-f)
385
386
          files)))

387
388
389
390
  ;; 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.
391
392
  (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
393
    (apply 'operate 'deliver-asd-op system args)))
394
395

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

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

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

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

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

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

443
  (defmethod perform ((o link-op) (c prebuilt-system))
444
    nil)
445

446
  (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
447
    nil)
448

449
  (defmethod perform ((o lib-op) (c prebuilt-system))
450
451
    nil)

452
  (defmethod perform ((o dll-op) (c prebuilt-system))
453
    nil)
454
455

  (defmethod component-depends-on ((o gather-op) (c prebuilt-system))
456
457
458
    nil)

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

461

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

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

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

535
536
537
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

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

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

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

554
555
556
  (defun system-module-pathname (module)
    (let ((name (coerce-name module)))
      (some
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
557
       'file-exists-p
558
559
560
561
562
563
564
       (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;")))))

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

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

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