bundle.lisp 20.5 KB
Newer Older
1
2
3
;;;; -------------------------------------------------------------------------
;;;; ASDF-Bundle

4
5
(asdf/package:define-package :asdf/bundle
  (:recycle :asdf/bundle :asdf)
6
  (:use :common-lisp :asdf/driver :asdf/upgrade
7
8
9
   :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
  (:export
10
   #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
11
   #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
12
   #:monolithic-op #:monolithic-bundle-op #:dependency-files
13
   #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
14
   #:program-op
15
   #:compiled-file #:precompiled-system #:prebuilt-system
16
17
   #:operation-monolithic-p
   #:user-system-p #:user-system #:trivial-system-p
18
   #:gather-actions #:operated-components
19
20
   #+ecl #:make-build #+mkcl #:bundle-system
   #:register-pre-built-system
21
   #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library
22
23
24
25
   #:component-translate-output-p #:translate-output-p
   #:component-bundle-pathname #:bundle-pathname
   #:component-bundle-operation #:bundle-operation
   #:component-entry-point #:entry-point))
26
27
28
29
30
(in-package :asdf/bundle)

(defclass bundle-op (operation)
  ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
   (name-suffix :initarg :name-suffix :initform nil)
31
   (bundle-type :reader bundle-type)
32
33
34
35
36
   #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
   #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
   #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))

(defclass fasl-op (bundle-op)
37
38
  ;; create a single fasl for the entire library
  ((bundle-type :initform :fasl)))
39

40
41
42
(defclass load-fasl-op (basic-load-op)
  ;; load a single fasl for the entire library
  ())
43
44

(defclass lib-op (bundle-op)
45
46
47
  ;; On ECL: compile the system and produce linkable .a library for it.
  ;; On others: just compile the system.
  ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
48
49

(defclass dll-op (bundle-op)
50
51
  ;; Link together all the dynamic library used by this system into a single one.
  ((bundle-type :initform :dll)))
52
53

(defclass binary-op (bundle-op)
54
55
  ;; On ECL: produce lib and fasl for the system.
  ;; On "normal" Lisps: produce just the fasl.
56
57
58
59
60
61
62
63
64
  ())

(defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies

(defclass monolithic-bundle-op (monolithic-op bundle-op)
  ((prologue-code :accessor monolithic-op-prologue-code)
   (epilogue-code :accessor monolithic-op-epilogue-code)))

(defclass monolithic-binary-op (binary-op monolithic-bundle-op)
65
66
  ;; On ECL: produce lib and fasl for combined system and dependencies.
  ;; On "normal" Lisps: produce an image file from system and dependencies.
67
68
  ())

69
70
71
(defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
  ;; Create a single fasl for the system and its dependencies.
  ())
72
73

(defclass monolithic-lib-op (monolithic-bundle-op lib-op)
74
75
  ;; ECL: Create a single linkable library for the system and its dependencies.
  ((bundle-type :initform :lib)))
76
77

(defclass monolithic-dll-op (monolithic-bundle-op dll-op)
78
  ((bundle-type :initform :dll)))
79
80

(defclass program-op (monolithic-bundle-op)
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
  ;; All: create an executable file from the system and its dependencies
  ((bundle-type :initform :program)))

(defgeneric* component-bundle-pathname (component))
(defgeneric* component-translate-output-p (component))
(defgeneric* component-entry-point (component))

(defmethod component-bundle-pathname ((c component))
  (declare (ignorable c))
  nil)
(defmethod component-translate-output-p ((c component))
  (declare (ignorable c))
  t)
(defmethod component-entry-point ((c component))
  (declare (ignorable c))
  nil)

(defclass bundle-system (system)
  ((bundle-pathname
    :initform nil :initarg :bundle-pathname :accessor component-bundle-pathname)
   (bundle-operation
    :initarg :bundle-operation :accessor component-bundle-operation)
   (entry-point
    :initform nil :initarg :entry-point :accessor component-entry-point)
   (translate-output-p
    :initform nil :initarg :translate-output-p :accessor component-translate-output-p)))

(defun* bundle-pathname-type (bundle-type)
  (etypecase bundle-type
    ((eql :no-output-file) nil) ;; should we error out instead?    
    ((or null string) bundle-type)
    ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
    #+ecl
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
114
    ((member :binary :dll :lib :static-library :program :object :program)
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
     (compile-file-type :type bundle-type))
    ((eql :binary) "image")
    ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
    ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
    ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))

(defun* bundle-output-files (o c)
  (let ((bundle-type (bundle-type o)))
    (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
      (let ((name (or (component-bundle-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))
                (not (component-translate-output-p c)))))))

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

#-(or ecl mkcl)
(progn
  (defmethod perform ((o program-op) (c system))
    (let ((output-file (output-file o c)))
      (setf *image-entry-point* (ensure-function (component-entry-point c)))
      (dump-image output-file :executable t)))

  (defmethod perform ((o monolithic-binary-op) (c system))
    (let ((output-file (output-file o c)))
      (dump-image output-file))))
143
144

(defclass compiled-file (file-component)
145
  ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
146
147

(defclass precompiled-system (system)
148
  ((bundle-pathname :initarg :fasl)))
149
150

(defclass prebuilt-system (system)
151
152
  ((bundle-pathname :initarg :static-library :initarg :lib
                    :accessor prebuilt-system-static-library)))
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171

;;;
;;; 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.
;;;

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

(defmethod initialize-instance :after ((instance bundle-op) &rest initargs
                                       &key (name-suffix nil name-suffix-p)
                                       &allow-other-keys)
  (declare (ignorable initargs name-suffix))
  (unless name-suffix-p
    (setf (slot-value instance 'name-suffix)
172
173
          (unless (typep instance 'program-op)
            (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system"))))
174
175
176
177
178
179
  (when (typep instance 'monolithic-bundle-op)
    (destructuring-bind (&rest original-initargs
                         &key lisp-files prologue-code epilogue-code
                         &allow-other-keys)
        (operation-original-initargs instance)
      (setf (operation-original-initargs instance)
180
            (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
181
182
            (monolithic-op-prologue-code instance) prologue-code
            (monolithic-op-epilogue-code instance) epilogue-code)
183
      #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
184
185
      #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
  (setf (bundle-op-build-args instance)
186
        (remove-plist-keys '(:type :monolithic :name-suffix)
187
188
189
190
191
192
193
194
                     (operation-original-initargs instance))))

(defmethod bundle-op-build-args :around ((o lib-op))
  (declare (ignorable o))
  (let ((args (call-next-method)))
    (remf args :ld-flags)
    args))

195
196
197
198
199
200
201
202
203
(defclass filtered-sequential-plan (sequential-plan)
  ((action-filter :initarg :action-filter :reader plan-action-filter)))

(defmethod action-valid-p ((plan filtered-sequential-plan) o c)
  (and (funcall (plan-action-filter plan) o c) (call-next-method)))

(defun* gather-actions (operation component &key other-systems (filter t))
  ;; This function creates a list of sub-actions performed
  ;; while building the targeted action.
204
  ;; This list may be restricted to sub-components of SYSTEM
205
206
207
208
209
210
211
212
213
  ;; if OTHER-SYSTEMS is NIL (default).
  (traverse operation component
            :plan-class 'filtered-sequential-plan
            :action-filter (ensure-function filter)
            :force (if other-systems :all t)
            :force-not (if other-systems nil :all)))

(defun* bundlable-file-p (pathname)
  (let ((type (pathname-type pathname)))
214
    (declare (ignorable type))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
215
216
    (or #+ecl (or (equal type (compile-file-type :type :object))
                  (equal type (compile-file-type :type :static-library)))
217
218
219
        #+mkcl (equal type (compile-file-type :fasl-p nil))
        #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))

220
(defun* operated-components (system &key (goal-operation 'load-op) (keep-operation goal-operation)
221
                                    (component-type t) (keep-component t) other-systems)
222
223
224
225
226
227
228
229
  (let ((goal-op (make-operation goal-operation)))
    (flet ((filter (o c)
             (declare (ignore o))
             (or (eq c system)
                 (typep c component-type))))
      (loop :for (o . c) :in (gather-actions goal-op system
                                             :other-systems other-systems
                                             :filter #'filter)
230
            :when (and (typep o keep-operation) (typep c keep-component))
231
              :collect c))))
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250

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

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

(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
;;;

251
252
(defmethod component-depends-on ((o monolithic-lib-op) (c system))
  (declare (ignorable o))
253
254
255
  `((lib-op ,@(operated-components c :other-systems t :component-type 'system
                                     :goal-operation 'load-op
                                     :keep-operation 'load-op))))
256

257
258
(defmethod component-depends-on ((o monolithic-fasl-op) (c system))
  (declare (ignorable o))
259
260
261
  `((fasl-op ,@(operated-components c :other-systems t :component-type 'system
                                      :goal-operation 'load-fasl-op
                                      :keep-operation 'load-fasl-op))))
262
263
264

(defmethod component-depends-on ((o program-op) (c system))
  (declare (ignorable o))
265
266
  #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c)
  #-(or ecl mkcl) `((load-op ,c)))
267
268
269
270
271
272
273
274
275

(defmethod component-depends-on ((o binary-op) (c system))
  (declare (ignorable o))
  `((fasl-op ,c)
    (lib-op ,c)))

(defmethod component-depends-on ((o monolithic-binary-op) (c system))
  `((,(find-operation o 'monolithic-fasl-op) ,c)
    (,(find-operation o 'monolithic-lib-op) ,c)))
276
277
278

(defmethod component-depends-on ((o lib-op) (c system))
  (declare (ignorable o))
279
280
281
  `((compile-op ,@(operated-components c :other-systems nil :component-type '(not system)
                                         :goal-operation 'load-op
                                         :keep-operation 'load-op))))
282
283
284
285
286
287
288
289
290

(defmethod component-depends-on ((o fasl-op) (c system))
  (declare (ignorable o))
  #+ecl `((lib-op ,c))
  #-ecl
  (component-depends-on (find-operation o 'lib-op) c))

(defmethod component-depends-on ((o dll-op) c)
  (component-depends-on (find-operation o 'lib-op) c))
291
292
293
294
295

(defmethod component-depends-on ((o bundle-op) c)
  (declare (ignorable o c))
  nil)

296
297
(defmethod component-depends-on :around ((o bundle-op) (c component))
  (declare (ignorable o c))
298
  (if-let (op (and (eq (type-of o) 'bundle-op) (component-bundle-operation c)))
299
300
301
      `((,op ,c))
      (call-next-method)))

302
(defun* dependency-files (o c &key (test 'identity) (key 'output-files))
303
304
305
  (while-collecting (collect)
    (visit-dependencies
     () o c #'(lambda (sub-o sub-c)
306
307
308
309
310
                (loop :for f :in (funcall key sub-o sub-c)
                      :when (funcall test f) :do (collect f))))))

(defmethod input-files ((o bundle-op) (c system))
  (dependency-files o c :test 'bundlable-file-p :key 'output-files))
311

312
(defun* select-bundle-operation (type &optional monolithic)
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
  (ecase type
    ((:binary)
     (if monolithic 'monolithic-binary-op 'binary-op))
    ((:dll :shared-library)
     (if monolithic 'monolithic-dll-op 'dll-op))
    ((:lib :static-library)
     (if monolithic 'monolithic-lib-op 'lib-op))
    ((:fasl)
     (if monolithic 'monolithic-fasl-op 'fasl-op))
    ((:program)
     'program-op)))

(defun* make-build (system &rest args &key (monolithic nil) (type :fasl)
                   (move-here nil move-here-p)
                   &allow-other-keys)
328
  (let* ((operation-name (select-bundle-operation type monolithic))
329
330
331
332
333
334
         (move-here-path (if (and move-here
                                  (typep move-here '(or pathname string)))
                             (pathname move-here)
                             (merge-pathnames "./asdf-output/")))
         (operation (apply #'operate operation-name
                           system
335
                           (remove-plist-keys '(:monolithic :type :move-here) args)))
336
337
338
339
         (system (find-system system))
         (files (and system (output-files operation system))))
    (if (or move-here (and (null move-here-p)
                           (member operation-name '(:program :binary))))
340
        (loop :with dest-path = (truename* (ensure-directories-exist move-here-path))
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
              :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)
        files)))

;;;
;;; LOAD-FASL-OP
;;;
;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
;;;

(defmethod component-depends-on ((o load-fasl-op) (c system))
  (declare (ignorable o))
357
358
  `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
                :collect (resolve-dependency-spec c dep)))
359
360
361
362
363
364
365
366
367
368
369
370
    (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
    ,@(call-next-method)))

(defmethod input-files ((o load-fasl-op) (c system))
  (when (user-system-p c)
    (output-files (find-operation o 'fasl-op) c)))

(defmethod perform ((o load-fasl-op) c)
  (declare (ignorable o c))
  nil)

(defmethod perform ((o load-fasl-op) (c system))
371
  (perform-lisp-load-fasl o c))
372
373

(defmethod mark-operation-done :after ((o load-fasl-op) (c system))
374
  (mark-operation-done (find-operation o 'load-op) c))
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392

;;;
;;; PRECOMPILED FILES
;;;
;;; This component can be used to distribute ASDF systems in precompiled form.
;;; Only useful when the dependencies have also been precompiled.
;;;

(defmethod trivial-system-p ((s system))
  (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))

(defmethod output-files (o (c compiled-file))
  (declare (ignorable o c))
  nil)
(defmethod input-files (o (c compiled-file))
  (declare (ignorable o))
  (component-pathname c))
(defmethod perform ((o load-op) (c compiled-file))
393
  (perform-lisp-load-fasl o c))
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
(defmethod perform ((o load-source-op) (c compiled-file))
  (perform (find-operation o 'load-op) c))
(defmethod perform ((o load-fasl-op) (c compiled-file))
  (perform (find-operation o 'load-op) c))
(defmethod perform (o (c compiled-file))
  (declare (ignorable o c))
  nil)

;;;
;;; Pre-built systems
;;;
(defmethod trivial-system-p ((s prebuilt-system))
  (declare (ignorable s))
  t)

(defmethod perform ((o lib-op) (c prebuilt-system))
  (declare (ignorable o c))
  nil)

413
(defmethod component-depends-on ((o lib-op) (c prebuilt-system))
414
415
416
  (declare (ignorable o c))
  nil)

417
(defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
418
419
420
  (declare (ignorable o))
  nil)

421

422
423
424
425
426
427
;;;
;;; PREBUILT SYSTEM CREATOR
;;;


(defmethod output-files ((o binary-op) (s system))
428
429
  (list (make-pathname :name (component-name s) :type "asd"
                       :defaults (component-pathname s))))
430
431

(defmethod perform ((o binary-op) (s system))
432
433
434
435
436
  (let* ((dependencies (component-depends-on o s))
         (fasl (first (apply #'output-files (first dependencies))))
         (library (first (apply #'output-files (second dependencies))))
         (asd (first (output-files o s)))
         (name (pathname-name asd))
437
         (name-keyword (intern (string name) (find-package :keyword))))
438
    (with-open-file (s asd :direction :output :if-exists :supersede
439
440
441
442
443
444
445
446
447
448
449
450
                       :if-does-not-exist :create)
      (format s ";;; Prebuilt ASDF definition for system ~A" name)
      (format s ";;; Built for ~A ~A on a ~A/~A ~A"
              (lisp-implementation-type)
              (lisp-implementation-version)
              (software-type)
              (machine-type)
              (software-version))
      (let ((*package* (find-package :keyword)))
        (pprint `(defsystem ,name-keyword
                     :class prebuilt-system
                     :components ((:compiled-file ,(pathname-name fasl)))
451
                     :lib ,(and library (file-namestring library)))
452
453
454
                s)))))

#-(or ecl mkcl)
455
(defmethod perform ((o fasl-op) (c system))
456
  (let* ((input-files (input-files o c))
457
458
         (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=))
         (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=))
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
         (output-files (output-files o c))
         (output-file (first output-files)))
    (when input-files
      (assert output-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 (and (typep o 'monolithic-bundle-op)
                 (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
        (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))
  (declare (ignorable o))
475
  (bundle-output-files (find-operation o 'fasl-op) s))
476
477
478
479
480
481
482
483
484
485
486
487

(defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
  (declare (ignorable o))
  `((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)
|#

#+ecl
(defmethod perform ((o bundle-op) (c system))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
488
489
490
491
492
493
494
  (let* ((object-files (input-files o c))
         (output (output-files o c))
         (bundle (first output))
         (kind (bundle-type o))
         (init-name (c::compute-init-name bundle :kind kind)))
    (apply #'c::builder kind (first output)
           :init-name init-name
495
496
497
498
499
           :lisp-files (append object-files (bundle-op-lisp-files o))
           (append (bundle-op-build-args o)
                   (when (and (typep o 'monolithic-bundle-op)
                              (monolithic-op-prologue-code o))
                     `(:prologue-code ,(monolithic-op-prologue-code o)))
500
501
502
                   (when (typep o 'program-op)
                     `(:epilogue-code
                       (restore-image :entry-point ,(component-entry-point c))))
503
504
505
506
507
508
                   (when (and (typep o 'monolithic-bundle-op)
                              (monolithic-op-epilogue-code o))
                     `(:epilogue-code ,(monolithic-op-epilogue-code o)))))))

#+mkcl
(progn
509
510
511
  (defmethod perform ((o lib-op) (s system))
    (apply #'compiler::build-static-library (first output)
           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
512

513
514
515
  (defmethod perform ((o fasl-op) (s system))
    (apply #'compiler::build-bundle (second output)
           :lisp-object-files (input-files o s) (bundle-op-build-args o)))
516

517
518
519
  (defun* bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
    (declare (ignore force verbose version))
    (apply #'operate 'binary-op system args)))
520
521
522
523

#+(or ecl mkcl)
(defun* register-pre-built-system (name)
  (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))