bundle.lisp 27.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
    ((build-args :initarg :args :initform nil :accessor extra-build-args)
27
28
     (name-suffix :initarg :name-suffix :initform nil)
     (bundle-type :initform :no-output-file :reader bundle-type)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
29
     #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files)))
30

31
32
33
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
itself.")) ;; operation on a system and its dependencies

  (defclass monolithic-bundle-op (monolithic-op bundle-op)
    ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation
40
41
    ((prologue-code :initform nil :accessor prologue-code)
     (epilogue-code :initform nil :accessor epilogue-code)))
42

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

57
58
  (defmethod prologue-code ((x t)) nil)
  (defmethod epilogue-code ((x t)) nil)
59
  (defmethod no-uiop ((x t)) nil)
60
61
62
63
  (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)
64
65
66
67
68

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

  (defclass gather-op (bundle-op)
69
70
    ((gather-op :initform nil :allocation :class :reader gather-op)
     (gather-type :initform :no-output-file :allocation :class :reader gather-type))
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
    (:documentation "Abstract operation for gathering many input files from a system"))

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

  (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))))
87

88
  ;; create a single fasl for the entire library
89
  (defclass basic-compile-bundle-op (bundle-op)
90
91
92
    ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
                  :allocation :class)
     (bundle-type :initform :fasl :allocation :class)))
93

94
  (defclass prepare-bundle-op (sideway-operation)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
95
96
97
    ((sideway-operation
      :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
      :allocation :class)))
98
99

  (defclass lib-op (link-op gather-op non-propagating-operation)
100
101
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :lib :allocation :class))
102
103
    (:documentation "Compile the system and produce linkable (.a) library for it.
Compare with DLL-OP."))
104

105
  (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
106
107
                               #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op)
    ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op)
108
109
110
111
112
                         :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."))
113

114
  (defclass load-bundle-op (basic-load-op selfward-operation)
115
116
117
118
119
    ((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."))
120
121

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

126
  (defclass dll-op (link-op gather-op non-propagating-operation)
127
128
    ((gather-type :initform :object :allocation :class)
     (bundle-type :initform :dll :allocation :class))
129
130
    (:documentation "compile the system and produce dynamic (.so/.dll) library for it.
Compare with LIB-OP."))
131

132
  (defclass deliver-asd-op (basic-compile-op selfward-operation)
133
134
135
136
137
    ((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))
138
    (:documentation "produce an asd file for delivering the system as a single fasl"))
139
140


141
  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
142
    ((selfward-operation
143
144
      ;; 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
145
146
      :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
      :allocation :class))
147
148
    (:documentation "produce fasl and asd files for combined system and dependencies."))

149
150
151
152
153
154
155
  (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))
156
    (:documentation "Create a single fasl for the system and its dependencies."))
157

158
159
160
161
  (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
162
163
  (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation)
    ((gather-type :initform :static-library :allocation :class))
164
    (:documentation "Create a single linkable library for the system and its dependencies."))
165

166
  (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
167
    ((gather-type :initform :static-library :allocation :class))
168
    (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
169

170
  (defclass image-op (monolithic-bundle-op selfward-operation
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
171
                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
172
    ((bundle-type :initform :image)
173
     #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
174
     (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
175
176
177
178
    (:documentation "create an image file from the system and its dependencies"))

  (defclass program-op (image-op)
    ((bundle-type :initform :program))
179
    (:documentation "create an executable file from the system and its dependencies"))
180
181
182

  (defun bundle-pathname-type (bundle-type)
    (etypecase bundle-type
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
      ((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")))))
206
207

  (defun bundle-output-files (o c)
208
209
210
211
212
213
214
    (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))
215
216
217
218
                  (eq (type-of o) (coerce-class (component-build-operation c)
                                                :package :asdf/interface
                                                :super 'operation
                                                :error nil)))))))
219
220
221
222

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

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
223
  #-(or clasp ecl mkcl)
224
225
226
227
228
  (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)))))
229
230

  (defclass compiled-file (file-component)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
231
    ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")))
232
233
234
235
236
237
238
239

  (defclass precompiled-system (system)
    ((build-pathname :initarg :fasl)))

  (defclass prebuilt-system (system)
    ((build-pathname :initarg :static-library :initarg :lib
                     :accessor prebuilt-system-static-library))))

240
241
242
243
244
245
246
247
248

;;;
;;; 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.
;;;
249
250
251
252
(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
253
    (declare (ignore initargs name-suffix))
254
255
256
    (unless name-suffix-p
      (setf (slot-value instance 'name-suffix)
            (unless (typep instance 'program-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
257
258
              ;; "." is no good separator for Logical Pathnames, so we use "--"
              (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system"))))
259
    (when (typep instance 'monolithic-bundle-op)
260
      (destructuring-bind (&key lisp-files prologue-code epilogue-code
261
262
                           &allow-other-keys)
          (operation-original-initargs instance)
263
264
        (setf (prologue-code instance) prologue-code
              (epilogue-code instance) epilogue-code)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
265
266
        #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code)))
        #+(or clasp ecl) (setf (extra-object-files instance) lisp-files)))
267
    (setf (extra-build-args instance)
268
          (remove-plist-keys
269
270
           '(: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
271
           (operation-original-initargs instance))))
272
273
274
275
276
277

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

  (defun user-system-p (s)
    (and (typep s 'system)
         (not (builtin-system-p s))
278
         (not (trivial-system-p s)))))
279

280
(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
281
  (deftype user-system () '(and system (satisfies user-system-p))))
282
283
284
285
286
287
288
289
290

;;;
;;; 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
;;;
291
292
(with-upgradability ()
  (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
293
294
    ;; This file selects output files from direct dependencies;
    ;; your component-depends-on method better gathered the correct dependencies in the correct order.
295
296
    (while-collecting (collect)
      (map-direct-dependencies
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
297
298
299
       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))))))
300

301
302
303
  (defun pathname-type-equal-function (type)
    #'(lambda (p) (equal (pathname-type p) type)))

304
  (defmethod input-files ((o gather-op) (c system))
305
    (unless (eq (bundle-type o) :no-output-file)
306
307
308
      (direct-dependency-files
       o c :key 'output-files
           :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
309
310
311
312
313
314
315
316

  (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)
317
       (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
318
319
      ((:image)
       'image-op)
320
321
322
      ((:program)
       'program-op)))

323
  ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it?
324
325
326
327
328
329
  (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)))
330
                               (ensure-pathname move-here :namestring :lisp :ensure-directory t)
331
332
333
334
335
336
337
                               (system-relative-pathname system "asdf-output/")))
           (operation (apply #'operate operation-name
                             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)
338
                             (member operation-name '(:program :image))))
339
340
341
342
343
344
345
          (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)
                :do (rename-file-overwriting-target f new-f)
                :collect new-f)
346
347
348
349
350
351
          files)))

  ;; DEPRECATED. Does anyone use this?
  (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    (declare (ignore force verbose version))
    (apply #'operate 'deliver-asd-op system args)))
352
353

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

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

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

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

;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;
381
382
383
384
(with-upgradability ()
  (defmethod trivial-system-p ((s system))
    (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
385
  (defmethod input-files ((o operation) (c compiled-file))
386
    (list (component-pathname c)))
387
388
389
390
  (defmethod perform ((o load-op) (c compiled-file))
    (perform-lisp-load-fasl o c))
  (defmethod perform ((o load-source-op) (c compiled-file))
    (perform (find-operation o 'load-op) c))
391
  (defmethod perform ((o operation) (c compiled-file))
392
    nil))
393
394
395
396

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

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

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

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

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

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

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

419

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

428
  (defmethod perform ((o deliver-asd-op) (s system))
429
430
431
    (let* ((inputs (input-files o s))
           (fasl (first inputs))
           (library (second inputs))
432
           (asd (first (output-files o s)))
433
           (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
434
           (version (component-version s))
435
436
437
438
439
440
441
           (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
442
                    t 'load-op s
443
444
445
446
447
448
449
450
                    #'(lambda (o c)
                        (when (and (typep o 'load-op) (typep c 'system))
                          (x c)))))))
           (depends-on (mapcar 'coerce-name dependencies)))
      (when (pathname-equal asd (system-source-file s))
        (cerror "overwrite the asd file"
                "~/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))
451
452
      (with-open-file (s asd :direction :output :if-exists :supersede
                             :if-does-not-exist :create)
453
454
455
        (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~%"
456
457
458
459
460
                (lisp-implementation-type)
                (lisp-implementation-version)
                (software-type)
                (machine-type)
                (software-version))
461
        (let ((*package* (find-package :asdf-user)))
462
          (pprint `(defsystem ,name
463
                     :class prebuilt-system
464
                     :version ,version
465
                     :depends-on ,depends-on
466
                     :components ((:compiled-file ,(pathname-name fasl)))
467
468
469
                     ,@(when library `(:lib ,(file-namestring library))))
                  s)
          (terpri s)))))
470

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

493
494
495
  (defmethod perform ((o load-op) (s precompiled-system))
    (perform-lisp-load-fasl o s))

496
  (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
497
    #+xcl (declare (ignorable o))
498
499
    `((load-op ,s) ,@(call-next-method))))

500
#| ;; Example use:
501
502
503
504
(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
505
#+(or clasp ecl mkcl)
506
(with-upgradability ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
507
508
509
510
511
  ;; I think that Juanjo intended for this to be, but it was disabled before 3.1
  ;; due to implementation bugs in ECL and MKCL that seem to have been fixed since
  ;; — see for ECL test-xach-update-bug.script and test-bundle.script,
  ;; and for MKCL test-logical-pathname.script.
  ;; We should probably reenable these after consulting with ECL and MKCL maintainers.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
512
  ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p))
513
  ;;  (setf *load-system-operation* 'load-bundle-op))
514

515
  (defun uiop-library-pathname ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
516
    #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object))
517
518
519
520
    #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style
              (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop"))

521
  (defun asdf-library-pathname ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
522
    #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object))
523
524
    #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
              (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
525
526
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))

527
  (defun compiler-library-pathname ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
528
    #+clasp (compile-file-pathname "sys:cmp" :output-type :lib)
529
530
531
    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))

532
  (defun make-library-system (name pathname)
533
534
    (make-instance 'prebuilt-system
                   :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
535
536
537
538
539

  (defmethod component-depends-on :around ((o image-op) (c system))
    (destructuring-bind ((lib-op . deps)) (call-next-method)
      (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
        `((,lib-op
540
541
542
543
           ,@(unless (or (no-uiop c) (has-it-p "cmp"))
               `(,(make-library-system
                   "cmp" (compiler-library-pathname))))
           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
544
545
546
547
548
549
               (cond
                 ((system-source-directory :uiop) `(,(find-system :uiop)))
                 ((system-source-directory :asdf) `(,(find-system :asdf)))
                 (t `(,@(if-let (uiop (uiop-library-pathname))
                          `(,(make-library-system "uiop" uiop)))
                      ,(make-library-system "asdf" (asdf-library-pathname))))))
550
551
           ,@deps)))))

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

572
#+(and (not asdf-use-unsafe-mac-bundle-op)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
573
       (or (and clasp ecl darwin)
574
           (and abcl darwin (not abcl-bundle-op-supported))))
575
(defmethod perform :before ((o basic-compile-bundle-op) (c component))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
576
  (unless (featurep :asdf-use-unsafe-mac-bundle-op)
577
    (cerror "Continue after modifying *FEATURES*."
578
            "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
579
580
To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~
Please report to ASDF-DEVEL if this works for you.")))