-
Notifications
You must be signed in to change notification settings - Fork 0
/
bundle.lisp
597 lines (526 loc) · 28.8 KB
/
bundle.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
;;;; -------------------------------------------------------------------------
;;;; ASDF-Bundle
(uiop/package:define-package :asdf/bundle
(:recycle :asdf/bundle :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/operation
:asdf/find-component ;; used by ECL
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/parse-defsystem)
(:export
#:bundle-op #:bundle-type #:program-system
#:bundle-system #:bundle-pathname-type #:direct-dependency-files
#:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
#:basic-compile-bundle-op #:prepare-bundle-op
#:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
#:lib-op #:monolithic-lib-op
#:dll-op #:monolithic-dll-op
#:deliver-asd-op #:monolithic-deliver-asd-op
#:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
#:user-system-p #:user-system #:trivial-system-p
#:prologue-code #:epilogue-code #:static-library))
(in-package :asdf/bundle)
(with-upgradability ()
(defclass bundle-op (operation) ()
(:documentation "base class for operations that bundle outputs from multiple components"))
(defgeneric bundle-type (bundle-op))
(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
itself."))
(defclass monolithic-bundle-op (bundle-op monolithic-op)
;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
;; DEPRECATED. Supported replacement: Define slots on program-system instead.
((prologue-code :initform nil :accessor prologue-code)
(epilogue-code :initform nil :accessor epilogue-code))
(:documentation "operations that are both monolithic-op and bundle-op"))
(defclass program-system (system)
;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
(epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
(no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
(prefix-lisp-object-files :initarg :prefix-lisp-object-files
:initform nil :accessor prefix-lisp-object-files)
(postfix-lisp-object-files :initarg :postfix-lisp-object-files
:initform nil :accessor postfix-lisp-object-files)
(extra-object-files :initarg :extra-object-files
:initform nil :accessor extra-object-files)
(extra-build-args :initarg :extra-build-args
:initform nil :accessor extra-build-args)))
(defmethod prologue-code ((x system)) nil)
(defmethod epilogue-code ((x system)) nil)
(defmethod no-uiop ((x system)) nil)
(defmethod prefix-lisp-object-files ((x system)) nil)
(defmethod postfix-lisp-object-files ((x system)) nil)
(defmethod extra-object-files ((x system)) nil)
(defmethod extra-build-args ((x system)) nil)
(defclass link-op (bundle-op) ()
(:documentation "Abstract operation for linking files together"))
(defclass gather-operation (bundle-op) ()
(:documentation "Abstract operation for gathering many input files from a system"))
(defgeneric gather-operation (gather-operation))
(defmethod gather-operation ((o gather-operation)) nil)
(defgeneric gather-type (gather-operation))
(defun operation-monolithic-p (op)
(typep op 'monolithic-op))
;; Dependencies of a gather-op are the actions of the dependent operation
;; 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).
(defmethod component-depends-on ((o gather-operation) (s system))
(let* ((mono (operation-monolithic-p o))
(go (make-operation (or (gather-operation o) 'compile-op)))
(bundle-p (typep go 'bundle-op))
;; In a non-mono operation, don't recurse to other systems.
;; In a mono operation gathering bundles, don't recurse inside systems.
(component-type (if mono (if bundle-p 'system t) '(not system)))
;; In the end, only keep system bundles or non-system bundles, depending.
(keep-component (if bundle-p 'system '(not system)))
(deps
;; Required-components only looks at the dependencies of an action, excluding the action
;; itself, so it may be safely used by an action recursing on its dependencies (which
;; may or may not be an overdesigned API, since in practice we never use it that way).
;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
;; cleaner, we will miss the load-op on the requested system itself, which doesn't
;; matter for a regular system, but matters, a lot, for a package-inferred-system.
;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
;; for our needs of gathering all the files we want to include in a bundle.
;; Note that we use basic-compile-op rather than compile-op so it will still work on
;; systems that would somehow load dependencies with load-bundle-op.
(required-components
s :other-systems mono :component-type component-type :keep-component keep-component
:goal-operation 'load-op :keep-operation 'basic-compile-op)))
`((,go ,@deps) ,@(call-next-method))))
;; Create a single fasl for the entire library
(defclass basic-compile-bundle-op (bundle-op basic-compile-op) ()
(:documentation "Base class for compiling into a bundle"))
(defmethod bundle-type ((o basic-compile-bundle-op)) :fasb)
(defmethod gather-type ((o basic-compile-bundle-op))
#-(or clasp ecl mkcl) :fasl
#+(or clasp ecl mkcl) :object)
;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
(defclass prepare-bundle-op (sideway-operation)
((sideway-operation
:initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
:allocation :class))
(:documentation "Operation class for loading the bundles of a system's dependencies"))
(defclass lib-op (link-op gather-operation non-propagating-operation) ()
(: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.
On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
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."))
(defmethod bundle-type ((o lib-op)) :lib)
(defmethod gather-type ((o lib-op)) :object)
;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
;; on other implementations, we combine (usually concatenate) the .fasl files into one.
(defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
#+(or clasp ecl mkcl) link-op)
((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
(: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."))
(defclass load-bundle-op (basic-load-op selfward-operation)
((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."))
;; NB: since the monolithic-op's can't be sideway-operation's,
;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
;; we'd have to have the monolithic-op not inherit from the main op,
;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
(defclass dll-op (link-op gather-operation non-propagating-operation) ()
(: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."))
(defmethod bundle-type ((o dll-op)) :dll)
(defmethod gather-type ((o dll-op)) :object)
(defclass deliver-asd-op (basic-compile-op selfward-operation)
((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))
(:documentation "produce an asd file for delivering the system as a single fasl"))
(defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
((selfward-operation
;; TODO: implement link-op on all implementations, and make that
;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
:initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
:allocation :class))
(:documentation "produce fasl and asd files for combined system and dependencies."))
(defclass monolithic-compile-bundle-op
(basic-compile-bundle-op monolithic-bundle-op
#+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
()
(:documentation "Create a single fasl for the system and its dependencies."))
(defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
(:documentation "Load a single fasl for the system and its dependencies."))
(defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation) ()
(: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."))
(defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation) ()
(: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"))
(defclass image-op (monolithic-bundle-op selfward-operation
#+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
((selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
(:documentation "create an image file from the system and its dependencies"))
(defmethod bundle-type ((o image-op)) :image)
#+(or clasp ecl mkcl) (defmethod gather-operation ((o image-op)) 'lib-op)
#+(or clasp ecl mkcl) (defmethod gather-type ((o image-op)) :static-library)
(defclass program-op (image-op) ()
(:documentation "create an executable file from the system and its dependencies"))
(defmethod bundle-type ((o program-op)) :program)
;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
(defun bundle-pathname-type (bundle-type)
(etypecase bundle-type
((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
(compile-file-type)) ; on image-based platforms, used as input and output
((eql :fasb) ;; the type of a fasl
#-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
#+(or ecl mkcl) "fasb"
#+clasp "fasp") ; 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)
#+clasp "fasp" ;(core:build-extension cmp:*default-object-type*)
#-clasp "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")))))
;; Compute the output-files for a given bundle action
(defun bundle-output-files (o c)
(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)
(let ((suffix
(unless (typep o 'program-op)
;; "." is no good separator for Logical Pathnames, so we use "--"
(if (operation-monolithic-p o)
"--all-systems"
;; These use a different type .fasb or .a instead of .fasl
#-(or clasp ecl mkcl) "--system"))))
(format nil "~A~@[~A~]" (coerce-filename (component-name c)) suffix))))
(type (bundle-pathname-type bundle-type)))
(values (list (subpathname (component-pathname c) name :type type))
(eq (class-of o) (coerce-class (component-build-operation c)
:package :asdf/interface
:super 'operation
:error nil)))))))
(defmethod output-files ((o bundle-op) (c system))
(bundle-output-files o c))
#-(or clasp ecl mkcl)
(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)))))
(defclass compiled-file (file-component)
((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."))
(defclass precompiled-system (system)
((build-pathname :initarg :fasb :initarg :fasl))
(:documentation "Class For a system that is delivered as a precompiled fasl"))
(defclass prebuilt-system (system)
((build-pathname :initarg :static-library :initarg :lib
:accessor prebuilt-system-static-library))
(:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
;;;
;;; 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.
;;;
(when-upgrading (:version "3.2.0")
;; Cancel any previously defined method
(defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
(declare (ignore initargs))))
(with-upgradability ()
(defgeneric trivial-system-p (component))
(defun user-system-p (s)
(and (typep s 'system)
(not (builtin-system-p s))
(not (trivial-system-p s)))))
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
(deftype user-system () '(and system (satisfies user-system-p))))
;;;
;;; 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
;;;
(with-upgradability ()
(defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
;; This function selects output files from direct dependencies;
;; your component-depends-on method must gather the correct dependencies in the correct order.
(while-collecting (collect)
(map-direct-dependencies
o c #'(lambda (sub-o sub-c)
(loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f))))))
(defun pathname-type-equal-function (type)
#'(lambda (p) (equalp (pathname-type p) type)))
(defmethod input-files ((o gather-operation) (c system))
(unless (eq (bundle-type o) :no-output-file)
(direct-dependency-files
o c :key 'output-files
:test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
;; Find the operation that produces a given bundle-type
(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))
((:fasb)
(if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
((:image)
'image-op)
((:program)
'program-op))))
;;;
;;; LOAD-BUNDLE-OP
;;;
;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
;;;
(with-upgradability ()
(defmethod component-depends-on ((o load-bundle-op) (c system))
`((,o ,@(component-sideway-dependencies c))
(,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
,@(call-next-method)))
(defmethod input-files ((o load-bundle-op) (c system))
(when (user-system-p c)
(output-files (find-operation o 'compile-bundle-op) c)))
(defmethod perform ((o load-bundle-op) (c system))
(when (input-files o c)
(perform-lisp-load-fasl o c)))
(defmethod mark-operation-done :after ((o load-bundle-op) (c system))
(mark-operation-done (find-operation o 'load-op) c)))
;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;
(with-upgradability ()
(defmethod trivial-system-p ((s system))
(every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
(defmethod input-files ((o operation) (c compiled-file))
(list (component-pathname c)))
(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))
(defmethod perform ((o operation) (c compiled-file))
nil))
;;;
;;; Pre-built systems
;;;
(with-upgradability ()
(defmethod trivial-system-p ((s prebuilt-system))
t)
(defmethod perform ((o link-op) (c prebuilt-system))
nil)
(defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
nil)
(defmethod perform ((o lib-op) (c prebuilt-system))
nil)
(defmethod perform ((o dll-op) (c prebuilt-system))
nil)
(defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
nil)
(defmethod output-files ((o lib-op) (c prebuilt-system))
(values (list (prebuilt-system-static-library c)) t)))
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
(with-upgradability ()
(defmethod output-files ((o deliver-asd-op) (s system))
(list (make-pathname :name (coerce-filename (component-name s)) :type "asd"
:defaults (component-pathname s))))
;; because of name collisions between the output files of different
;; subclasses of DELIVER-ASD-OP, we cannot trust the file system to
;; tell us if the output file is up-to-date, so just treat the
;; operation as never being done.
(defmethod operation-done-p ((o deliver-asd-op) (s system))
(declare (ignorable o s))
nil)
(defun space-for-crlf (s)
(substitute-if #\space #'(lambda (x) (find x +crlf+)) s))
(defmethod perform ((o deliver-asd-op) (s system))
"Write an ASDF system definition for loading S as a delivered system."
(let* ((inputs (input-files o s))
(fasl (first inputs))
(library (second inputs))
(asd (output-file o s))
(name (if (and fasl asd) (pathname-name asd) (return-from perform)))
(version (component-version s))
(dependencies
(if (operation-monolithic-p o)
;; We want only dependencies, and we use basic-load-op rather than load-op so that
;; this will keep working on systems that load dependencies with load-bundle-op
(remove-if-not 'builtin-system-p
(required-components s :component-type 'system
:keep-operation 'basic-load-op))
(while-collecting (x) ;; resolve the sideway-dependencies of s
(map-direct-dependencies
'prepare-op s
#'(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))
(with-open-file (s asd :direction :output :if-exists :supersede
:if-does-not-exist :create)
(format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
(operation-monolithic-p o) name)
;; this can cause bugs in cases where one of the functions returns a multi-line
;; string
(let ((description-string (format nil ";;; Built for ~A ~A on a ~A/~A ~A"
(lisp-implementation-type)
(lisp-implementation-version)
(software-type)
(machine-type)
(software-version))))
;; ensure the whole thing is on one line
(println (space-for-crlf description-string) s))
(let ((*package* (find-package :asdf-user)))
(pprint `(defsystem ,name
:class prebuilt-system
:version ,version
:depends-on ,depends-on
:components ((:compiled-file ,(pathname-name fasl)))
,@(when library `(:lib ,(file-namestring library))))
s)
(terpri s)))))
#-(or clasp ecl mkcl)
(defmethod perform ((o basic-compile-bundle-op) (c system))
(let* ((input-files (input-files o c))
(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))
(output-files (output-files o c)) ; can't use OUTPUT-FILE fn because possibility it's NIL
(output-file (first output-files)))
(assert (eq (not input-files) (not output-files)))
(when input-files
(when non-fasl-files
(error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
(implementation-type) non-fasl-files))
(when (or (prologue-code c) (epilogue-code c))
(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))
(bundle-output-files (find-operation o 'compile-bundle-op) s))
(defmethod perform ((o load-op) (s precompiled-system))
(perform-lisp-load-fasl o s))
(defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
`((load-op ,s) ,@(call-next-method))))
#| ;; Example use:
(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)
|#
#+(or clasp ecl mkcl)
(with-upgradability ()
(defun system-module-pathname (module)
(let ((name (coerce-name module)))
(some
'file-exists-p
(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 (strcat "lib" 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;")))))
(defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
"Creates a prebuilt-system if PATHNAME isn't NIL."
(when pathname
(make-instance 'prebuilt-system
:name (coerce-name name)
:static-library (resolve-symlinks* pathname))))
(defun linkable-system (x)
(or ;; If the system is available as source, use it.
(if-let (s (find-system x))
(and (output-files 'lib-op s) s))
;; If an ASDF upgrade is available from source, but not a UIOP upgrade to that,
;; then use the asdf/driver system instead of
;; the UIOP that was disabled by check-not-old-asdf-system.
(if-let (s (and (equal (coerce-name x) "uiop")
(output-files 'lib-op "asdf")
(find-system "asdf/driver")))
(and (output-files 'lib-op s) s))
;; If there was no source upgrade, look for modules provided by the implementation.
(if-let (p (system-module-pathname (coerce-name x)))
(make-prebuilt-system x p))))
(defmethod component-depends-on :around ((o image-op) (c system))
(let* ((next (call-next-method))
(deps (make-hash-table :test 'equal))
(linkable (loop :for (do . dcs) :in next :collect
(cons do
(loop :for dc :in dcs
:for dep = (and dc (resolve-dependency-spec c dc))
:when dep
:do (setf (gethash (coerce-name (component-system dep)) deps) t)
:collect (or (and (typep dep 'system) (linkable-system dep)) dep))))))
`((lib-op
,@(unless (no-uiop c)
(list (linkable-system "cmp")
(unless (or (and (gethash "uiop" deps) (linkable-system "uiop"))
(and (gethash "asdf" deps) (linkable-system "asdf")))
(or (linkable-system "uiop")
(linkable-system "asdf")
"asdf")))))
,@linkable)))
(defmethod perform ((o link-op) (c system))
(let* ((object-files (input-files o c))
(output (output-files o c))
(bundle (first output))
(programp (typep o 'program-op))
(kind (bundle-type o)))
(when output
(apply 'create-image
bundle (append
(when programp (prefix-lisp-object-files c))
object-files
(when programp (postfix-lisp-object-files c)))
:kind kind
:prologue-code (when programp (prologue-code c))
:epilogue-code (when programp (epilogue-code c))
:build-args (when programp (extra-build-args c))
:extra-object-files (when programp (extra-object-files c))
:no-uiop (no-uiop c)
(when programp `(:entry-point ,(component-entry-point c))))))))