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

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

74
75
  (defclass gather-operation (bundle-op)
    ((gather-operation :initform nil :allocation :class :reader gather-operation)
76
     (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
  ;; Dependencies of a gather-op are the actions of the dependent operation
83
84
85
86
87
  ;; 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).
88
  (defmethod component-depends-on ((o gather-operation) (s system))
89
90
91
92
93
94
95
96
    (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.
97
      `((,(or (gather-operation o) (if mono 'lib-op 'compile-op)) ,@deps)
98
        ,@(call-next-method))))
99

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

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

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

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

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

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

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

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


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

170
171
  (defclass monolithic-compile-bundle-op
      (monolithic-bundle-op basic-compile-bundle-op
172
173
174
175
176
177
178
       #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
    ((gather-operation
      :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))
179
    (:documentation "Create a single fasl for the system and its dependencies."))
180

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

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

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

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

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

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

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

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

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

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

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

272
273
274
275
276
277
278
279
280

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

306
  (defgeneric trivial-system-p (component))
307
308
309
310

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

464

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

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

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

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

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

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

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

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

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

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

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