toolchain/bundle.lisp

   1 ;;;; -------------------------------------------------------------------------
   2 ;;;; ASDF-Bundle
   3
   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    #:basic-compile-bundle-op #:prepare-bundle-op
  14    #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
  15    #:lib-op #:monolithic-lib-op
  16    #:dll-op #:monolithic-dll-op
  17    #:deliver-asd-op #:monolithic-deliver-asd-op
  18    #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system
  19    #:user-system-p #:user-system #:trivial-system-p
  20    #:prologue-code #:epilogue-code #:static-library))
  21 (in-package :asdf/bundle)
  22
  23 (with-upgradability ()
  24   (defclass bundle-op (basic-compile-op)
  25     ;; NB: use of instance-allocated slots for operations is DEPRECATED
  26     ;; and only supported in a temporary fashion for backward compatibility.
  27     ;; Supported replacement: Define slots on program-system instead.
  28     ((bundle-type :initform :no-output-file :reader bundle-type :allocation :class))
  29     (:documentation "base class for operations that bundle outputs from multiple components"))
  30
  31   (defclass monolithic-op (operation) ()
  32     (:documentation "A MONOLITHIC operation operates on a system *and all of its
  33 dependencies*.  So, for example, a monolithic concatenate operation will
  34 concatenate together a system's components and all of its dependencies, but a
  35 simple concatenate operation will concatenate only the components of the system
  36 itself."))
  37
  38   (defclass monolithic-bundle-op (bundle-op monolithic-op)
  39     ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation.
  40     ;; DEPRECATED. Supported replacement: Define slots on program-system instead.
  41     ((prologue-code :initform nil :accessor prologue-code)
  42      (epilogue-code :initform nil :accessor epilogue-code))
  43     (:documentation "operations that are both monolithic-op and bundle-op"))
  44
  45   (defclass program-system (system)
  46     ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
  47     ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
  48      (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
  49      (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
  50      (prefix-lisp-object-files :initarg :prefix-lisp-object-files
  51                                :initform nil :accessor prefix-lisp-object-files)
  52      (postfix-lisp-object-files :initarg :postfix-lisp-object-files
  53                                 :initform nil :accessor postfix-lisp-object-files)
  54      (extra-object-files :initarg :extra-object-files
  55                          :initform nil :accessor extra-object-files)
  56      (extra-build-args :initarg :extra-build-args
  57                        :initform nil :accessor extra-build-args)))
  58
  59   (defmethod prologue-code ((x system)) nil)
  60   (defmethod epilogue-code ((x system)) nil)
  61   (defmethod no-uiop ((x system)) nil)
  62   (defmethod prefix-lisp-object-files ((x system)) nil)
  63   (defmethod postfix-lisp-object-files ((x system)) nil)
  64   (defmethod extra-object-files ((x system)) nil)
  65   (defmethod extra-build-args ((x system)) nil)
  66
  67   (defclass link-op (bundle-op) ()
  68     (:documentation "Abstract operation for linking files together"))
  69
  70   (defclass gather-operation (bundle-op)
  71     ((gather-operation :initform nil :allocation :class :reader gather-operation)
  72      (gather-type :initform :no-output-file :allocation :class :reader gather-type))
  73     (:documentation "Abstract operation for gathering many input files from a system"))
  74
  75   (defun operation-monolithic-p (op)
  76     (typep op 'monolithic-op))
  77
  78   ;; Dependencies of a gather-op are the actions of the dependent operation
  79   ;; for all the (sorted) required components for loading the system.
  80   ;; Monolithic operations typically use lib-op as the dependent operation,
  81   ;; and all system-level dependencies as required components.
  82   ;; Non-monolithic operations typically use compile-op as the dependent operation,
  83   ;; and all transitive sub-components as required components (excluding other systems).
  84   (defmethod component-depends-on ((o gather-operation) (s system))
  85     (let* ((mono (operation-monolithic-p o))
  86            (go (make-operation (or (gather-operation o) 'compile-op)))
  87            (bundle-p (typep go 'bundle-op))
  88            ;; In a non-mono operation, don't recurse to other systems.
  89            ;; In a mono operation gathering bundles, don't recurse inside systems.
  90            (component-type (if mono (if bundle-p 'system t) '(not system)))
  91            ;; In the end, only keep system bundles or non-system bundles, depending.
  92            (keep-component (if bundle-p 'system '(not system)))
  93            (deps
  94             ;; Required-components only looks at the dependencies of an action, excluding the action
  95             ;; itself, so it may be safely used by an action recursing on its dependencies (which
  96             ;; may or may not be an overdesigned API, since in practice we never use it that way).
  97             ;; Therefore, if we use :goal-operation 'load-op :keep-operation 'load-op, which looks
  98             ;; cleaner, we will miss the load-op on the requested system itself, which doesn't
  99             ;; matter for a regular system, but matters, a lot, for a package-inferred-system.
 100             ;; Using load-op as the goal operation and basic-compile-op as the keep-operation works
 101             ;; for our needs of gathering all the files we want to include in a bundle.
 102             ;; Note that we use basic-compile-op rather than compile-op so it will still work on
 103             ;; systems when *load-system-operation* is load-bundle-op.
 104             (required-components
 105              s :other-systems mono :component-type component-type :keep-component keep-component
 106              :goal-operation 'load-op :keep-operation 'basic-compile-op)))
 107       `((,go ,@deps) ,@(call-next-method))))
 108
 109   ;; Create a single fasl for the entire library
 110   (defclass basic-compile-bundle-op (bundle-op)
 111     ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
 112                   :allocation :class)
 113      (bundle-type :initform :fasl :allocation :class))
 114     (:documentation "Base class for compiling into a bundle"))
 115
 116   ;; Analog to prepare-op, for load-bundle-op and compile-bundle-op
 117   (defclass prepare-bundle-op (sideway-operation)
 118     ((sideway-operation
 119       :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op
 120       :allocation :class))
 121     (:documentation "Operation class for loading the bundles of a system's dependencies"))
 122
 123   (defclass lib-op (link-op gather-operation non-propagating-operation)
 124     ((gather-type :initform :object :allocation :class)
 125      (bundle-type :initform :lib :allocation :class))
 126     (:documentation "Compile the system and produce a linkable static library (.a/.lib)
 127 for all the linkable object files associated with the system. Compare with DLL-OP.
 128
 129 On most implementations, these object files only include extensions to the runtime
 130 written in C or another language with a compiler producing linkable object files.
 131 On CLASP, ECL, MKCL, these object files _also_ include the contents of Lisp files
 132 themselves. In any case, this operation will produce what you need to further build
 133 a static runtime for your system, or a dynamic library to load in an existing runtime."))
 134
 135   ;; What works: on ECL, CLASP(?), MKCL, we link the many .o files from the system into the .so;
 136   ;; on other implementations, we combine (usually concatenate) the .fasl files into one.
 137   (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation gather-operation
 138                                                        #+(or clasp ecl mkcl) link-op)
 139     ((selfward-operation :initform '(prepare-bundle-op) :allocation :class))
 140     (:documentation "This operator is an alternative to COMPILE-OP. Build a system
 141 and all of its dependencies, but build only a single (\"monolithic\") FASL, instead
 142 of one per source file, which may be more resource efficient.  That monolithic
 143 FASL should be loaded with LOAD-BUNDLE-OP, rather than LOAD-OP."))
 144
 145   (defclass load-bundle-op (basic-load-op selfward-operation)
 146     ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))
 147     (:documentation "This operator is an alternative to LOAD-OP. Build a system
 148 and all of its dependencies, using COMPILE-BUNDLE-OP. The difference with
 149 respect to LOAD-OP is that it builds only a single FASL, which may be
 150 faster and more resource efficient."))
 151
 152   ;; NB: since the monolithic-op's can't be sideway-operation's,
 153   ;; if we wanted lib-op, dll-op, deliver-asd-op to be sideway-operation's,
 154   ;; we'd have to have the monolithic-op not inherit from the main op,
 155   ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
 156
 157   (defclass dll-op (link-op gather-operation non-propagating-operation)
 158     ((gather-type :initform :object :allocation :class)
 159      (bundle-type :initform :dll :allocation :class))
 160     (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
 161 for all the linkable object files associated with the system. Compare with LIB-OP."))
 162
 163   (defclass deliver-asd-op (basic-compile-op selfward-operation)
 164     ((selfward-operation
 165       ;; TODO: implement link-op on all implementations, and make that
 166       ;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
 167       :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
 168       :allocation :class))
 169     (:documentation "produce an asd file for delivering the system as a single fasl"))
 170
 171
 172   (defclass monolithic-deliver-asd-op (deliver-asd-op monolithic-bundle-op)
 173     ((selfward-operation
 174       ;; TODO: implement link-op on all implementations, and make that
 175       ;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
 176       :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
 177       :allocation :class))
 178     (:documentation "produce fasl and asd files for combined system and dependencies."))
 179
 180   (defclass monolithic-compile-bundle-op
 181       (basic-compile-bundle-op monolithic-bundle-op
 182        #+(or clasp ecl mkcl) link-op gather-operation non-propagating-operation)
 183     ()
 184     (:documentation "Create a single fasl for the system and its dependencies."))
 185
 186   (defclass monolithic-load-bundle-op (load-bundle-op monolithic-bundle-op)
 187     ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))
 188     (:documentation "Load a single fasl for the system and its dependencies."))
 189
 190   (defclass monolithic-lib-op (lib-op monolithic-bundle-op non-propagating-operation)
 191     ((gather-type :initform :object :allocation :class))
 192     (:documentation "Compile the system and produce a linkable static library (.a/.lib)
 193 for all the linkable object files associated with the system or its dependencies. See LIB-OP."))
 194
 195   (defclass monolithic-dll-op (dll-op monolithic-bundle-op non-propagating-operation)
 196     ((gather-type :initform :object :allocation :class))
 197     (:documentation "Compile the system and produce a dynamic loadable library (.so/.dll)
 198 for all the linkable object files associated with the system or its dependencies. See LIB-OP"))
 199
 200   (defclass image-op (monolithic-bundle-op selfward-operation
 201                       #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-operation)
 202     ((bundle-type :initform :image :allocation :class)
 203      (gather-operation :initform 'lib-op :allocation :class)
 204      #+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
 205      (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
 206     (:documentation "create an image file from the system and its dependencies"))
 207
 208   (defclass program-op (image-op)
 209     ((bundle-type :initform :program :allocation :class))
 210     (:documentation "create an executable file from the system and its dependencies"))
 211
 212   ;; From the ASDF-internal bundle-type identifier, get a filesystem-usable pathname type.
 213   (defun bundle-pathname-type (bundle-type)
 214     (etypecase bundle-type
 215       ((or null string) ;; pass through nil or string literal
 216        bundle-type)
 217       ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
 218        (error "No output file, therefore no pathname type"))
 219       ((eql :fasl) ;; the type of a fasl
 220        #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
 221        #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles
 222       ((member :image)
 223        #+allegro "dxl"
 224        #+(and clisp os-windows) "exe"
 225        #-(or allegro (and clisp os-windows)) "image")
 226       ;; NB: on CLASP and ECL these implementations, we better agree with
 227       ;; (compile-file-type :type bundle-type))
 228       ((eql :object) ;; the type of a linkable object file
 229        (os-cond ((os-unix-p) "o")
 230                 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "o" "obj"))))
 231       ((member :lib :static-library) ;; the type of a linkable library
 232        (os-cond ((os-unix-p) "a")
 233                 ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
 234       ((member :dll :shared-library) ;; the type of a shared library
 235        (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
 236       ((eql :program) ;; the type of an executable program
 237        (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
 238
 239   ;; Compute the output-files for a given bundle action
 240   (defun bundle-output-files (o c)
 241     (let ((bundle-type (bundle-type o)))
 242       (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
 243                   (and (null (input-files o c)) (not (member bundle-type '(:image :program)))))
 244         (let ((name (or (component-build-pathname c)
 245                         (let ((suffix
 246                                (unless (typep o 'program-op)
 247                                  ;; "." is no good separator for Logical Pathnames, so we use "--"
 248                                  (if (operation-monolithic-p o)
 249                                      "--all-systems"
 250                                      ;; These use a different type .fasb or .a instead of .fasl
 251                                      #-(or clasp ecl mkcl) "--system"))))
 252                           (format nil "~A~@[~A~]" (component-name c) suffix))))
 253               (type (bundle-pathname-type bundle-type)))
 254           (values (list (subpathname (component-pathname c) name :type type))
 255                   (eq (class-of o) (coerce-class (component-build-operation c)
 256                                                  :package :asdf/interface
 257                                                  :super 'operation
 258                                                  :error nil)))))))
 259
 260   (defmethod output-files ((o bundle-op) (c system))
 261     (bundle-output-files o c))
 262
 263   #-(or clasp ecl mkcl)
 264   (progn
 265     (defmethod perform ((o image-op) (c system))
 266       (dump-image (output-file o c) :executable (typep o 'program-op)))
 267     (defmethod perform :before ((o program-op) (c system))
 268       (setf *image-entry-point* (ensure-function (component-entry-point c)))))
 269
 270   (defclass compiled-file (file-component)
 271     ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))
 272     (:documentation "Class for a file that is already compiled,
 273 e.g. as part of the implementation, of an outer build system that calls into ASDF,
 274 or of opaque libraries shipped along the source code."))
 275
 276   (defclass precompiled-system (system)
 277     ((build-pathname :initarg :fasl))
 278     (:documentation "Class For a system that is delivered as a precompiled fasl"))
 279
 280   (defclass prebuilt-system (system)
 281     ((build-pathname :initarg :static-library :initarg :lib
 282                      :accessor prebuilt-system-static-library))
 283     (:documentation "Class for a system delivered with a linkable static library (.a/.lib)")))
 284
 285
 286 ;;;
 287 ;;; BUNDLE-OP
 288 ;;;
 289 ;;; This operation takes all components from one or more systems and
 290 ;;; creates a single output file, which may be
 291 ;;; a FASL, a statically linked library, a shared library, etc.
 292 ;;; The different targets are defined by specialization.
 293 ;;;
 294 (when-upgrading (:version "3.2.0")
 295   ;; Cancel any previously defined method
 296   (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key &allow-other-keys)
 297     (declare (ignore initargs))))
 298
 299 (with-upgradability ()
 300   (defgeneric trivial-system-p (component))
 301
 302   (defun user-system-p (s)
 303     (and (typep s 'system)
 304          (not (builtin-system-p s))
 305          (not (trivial-system-p s)))))
 306
 307 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
 308   (deftype user-system () '(and system (satisfies user-system-p))))
 309
 310 ;;;
 311 ;;; First we handle monolithic bundles.
 312 ;;; These are standalone systems which contain everything,
 313 ;;; including other ASDF systems required by the current one.
 314 ;;; A PROGRAM is always monolithic.
 315 ;;;
 316 ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
 317 ;;;
 318 (with-upgradability ()
 319   (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
 320     ;; This function selects output files from direct dependencies;
 321     ;; your component-depends-on method must gather the correct dependencies in the correct order.
 322     (while-collecting (collect)
 323       (map-direct-dependencies
 324        t o c #'(lambda (sub-o sub-c)
 325                  (loop :for f :in (funcall key sub-o sub-c)
 326                        :when (funcall test f) :do (collect f))))))
 327
 328   (defun pathname-type-equal-function (type)
 329     #'(lambda (p) (equalp (pathname-type p) type)))
 330
 331   (defmethod input-files ((o gather-operation) (c system))
 332     (unless (eq (bundle-type o) :no-output-file)
 333       (direct-dependency-files
 334        o c :key 'output-files
 335            :test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
 336
 337   ;; Find the operation that produces a given bundle-type
 338   (defun select-bundle-operation (type &optional monolithic)
 339     (ecase type
 340       ((:dll :shared-library)
 341        (if monolithic 'monolithic-dll-op 'dll-op))
 342       ((:lib :static-library)
 343        (if monolithic 'monolithic-lib-op 'lib-op))
 344       ((:fasl)
 345        (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op))
 346       ((:image)
 347        'image-op)
 348       ((:program)
 349        'program-op))))
 350
 351 ;;;
 352 ;;; LOAD-BUNDLE-OP
 353 ;;;
 354 ;;; This is like ASDF's LOAD-OP, but using bundle fasl files.
 355 ;;;
 356 (with-upgradability ()
 357   (defmethod component-depends-on ((o load-bundle-op) (c system))
 358     `((,o ,@(component-sideway-dependencies c))
 359       (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c)
 360       ,@(call-next-method)))
 361
 362   (defmethod input-files ((o load-bundle-op) (c system))
 363     (when (user-system-p c)
 364       (output-files (find-operation o 'compile-bundle-op) c)))
 365
 366   (defmethod perform ((o load-bundle-op) (c system))
 367     (when (input-files o c)
 368       (perform-lisp-load-fasl o c)))
 369
 370   (defmethod mark-operation-done :after ((o load-bundle-op) (c system))
 371     (mark-operation-done (find-operation o 'load-op) c)))
 372
 373 ;;;
 374 ;;; PRECOMPILED FILES
 375 ;;;
 376 ;;; This component can be used to distribute ASDF systems in precompiled form.
 377 ;;; Only useful when the dependencies have also been precompiled.
 378 ;;;
 379 (with-upgradability ()
 380   (defmethod trivial-system-p ((s system))
 381     (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
 382
 383   (defmethod input-files ((o operation) (c compiled-file))
 384     (list (component-pathname c)))
 385   (defmethod perform ((o load-op) (c compiled-file))
 386     (perform-lisp-load-fasl o c))
 387   (defmethod perform ((o load-source-op) (c compiled-file))
 388     (perform (find-operation o 'load-op) c))
 389   (defmethod perform ((o operation) (c compiled-file))
 390     nil))
 391
 392 ;;;
 393 ;;; Pre-built systems
 394 ;;;
 395 (with-upgradability ()
 396   (defmethod trivial-system-p ((s prebuilt-system))
 397     t)
 398
 399   (defmethod perform ((o link-op) (c prebuilt-system))
 400     nil)
 401
 402   (defmethod perform ((o basic-compile-bundle-op) (c prebuilt-system))
 403     nil)
 404
 405   (defmethod perform ((o lib-op) (c prebuilt-system))
 406     nil)
 407
 408   (defmethod perform ((o dll-op) (c prebuilt-system))
 409     nil)
 410
 411   (defmethod component-depends-on ((o gather-operation) (c prebuilt-system))
 412     nil)
 413
 414   (defmethod output-files ((o lib-op) (c prebuilt-system))
 415     (values (list (prebuilt-system-static-library c)) t)))
 416
 417
 418 ;;;
 419 ;;; PREBUILT SYSTEM CREATOR
 420 ;;;
 421 (with-upgradability ()
 422   (defmethod output-files ((o deliver-asd-op) (s system))
 423     (list (make-pathname :name (component-name s) :type "asd"
 424                          :defaults (component-pathname s))))
 425
 426   (defmethod perform ((o deliver-asd-op) (s system))
 427     (let* ((inputs (input-files o s))
 428            (fasl (first inputs))
 429            (library (second inputs))
 430            (asd (first (output-files o s)))
 431            (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
 432            (version (component-version s))
 433            (dependencies
 434              (if (operation-monolithic-p o)
 435                  ;; We want only dependencies, and we use basic-load-op rather than load-op so that
 436                  ;; this will keep working on systems when *load-system-operation* is load-bundle-op
 437                  (remove-if-not 'builtin-system-p
 438                                 (required-components s :component-type 'system
 439                                                        :keep-operation 'basic-load-op))
 440                  (while-collecting (x) ;; resolve the sideway-dependencies of s
 441                    (map-direct-dependencies
 442                     t 'load-op s
 443                     #'(lambda (o c)
 444                         (when (and (typep o 'load-op) (typep c 'system))
 445                           (x c)))))))
 446            (depends-on (mapcar 'coerce-name dependencies)))
 447       (when (pathname-equal asd (system-source-file s))
 448         (cerror "overwrite the asd file"
 449                 "~/asdf-action:format-action/ is going to overwrite the system definition file ~S ~
 450 which is probably not what you want; you probably need to tweak your output translations."
 451                 (cons o s) asd))
 452       (with-open-file (s asd :direction :output :if-exists :supersede
 453                              :if-does-not-exist :create)
 454         (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
 455                 (operation-monolithic-p o) name)
 456         (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
 457                 (lisp-implementation-type)
 458                 (lisp-implementation-version)
 459                 (software-type)
 460                 (machine-type)
 461                 (software-version))
 462         (let ((*package* (find-package :asdf-user)))
 463           (pprint `(defsystem ,name
 464                      :class prebuilt-system
 465                      :version ,version
 466                      :depends-on ,depends-on
 467                      :components ((:compiled-file ,(pathname-name fasl)))
 468                      ,@(when library `(:lib ,(file-namestring library))))
 469                   s)
 470           (terpri s)))))
 471
 472   #-(or clasp ecl mkcl)
 473   (defmethod perform ((o basic-compile-bundle-op) (c system))
 474     (let* ((input-files (input-files o c))
 475            (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
 476            (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
 477            (output-files (output-files o c))
 478            (output-file (first output-files)))
 479       (assert (eq (not input-files) (not output-files)))
 480       (when input-files
 481         (when non-fasl-files
 482           (error "On ~A, asdf/bundle can only bundle FASL files, but these were also produced: ~S"
 483                  (implementation-type) non-fasl-files))
 484         (when (or (prologue-code c) (epilogue-code c))
 485           (error "prologue-code and epilogue-code are not supported on ~A"
 486                  (implementation-type)))
 487         (with-staging-pathname (output-file)
 488           (combine-fasls fasl-files output-file)))))
 489
 490   (defmethod input-files ((o load-op) (s precompiled-system))
 491     (bundle-output-files (find-operation o 'compile-bundle-op) s))
 492
 493   (defmethod perform ((o load-op) (s precompiled-system))
 494     (perform-lisp-load-fasl o s))
 495
 496   (defmethod component-depends-on ((o load-bundle-op) (s precompiled-system))
 497     #+xcl (declare (ignorable o))
 498     `((load-op ,s) ,@(call-next-method))))
 499
 500 #| ;; Example use:
 501 (asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
 502 (asdf:load-system :precompiled-asdf-utils)
 503 |#
 504
 505 #+(or clasp ecl mkcl)
 506 (with-upgradability ()
 507
 508   #+ecl ;; doesn't work on clasp or mkcl (yet?).
 509   (unless (use-ecl-byte-compiler-p)
 510     (setf *load-system-operation* 'load-bundle-op))
 511
 512   (defun system-module-pathname (module)
 513     (let ((name (coerce-name module)))
 514       (some
 515        'file-exists-p
 516        (list
 517         #+clasp (compile-file-pathname (make-pathname :name name :defaults "sys:") :output-type :object)
 518         #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :lib)
 519         #+ecl (compile-file-pathname (make-pathname :name name :defaults "sys:") :type :object)
 520         #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:")
 521         #+mkcl (make-pathname :name name :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;")))))
 522
 523   (defun make-prebuilt-system (name &optional (pathname (system-module-pathname name)))
 524     "Creates a prebuilt-system if PATHNAME isn't NIL."
 525     (when pathname
 526       (make-instance 'prebuilt-system
 527                      :name (coerce-name name)
 528                      :static-library (resolve-symlinks* pathname))))
 529
 530   (defmethod component-depends-on :around ((o image-op) (c system))
 531     (destructuring-bind ((lib-op . deps)) (call-next-method)
 532       (labels ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))
 533                (ensure-linkable-system (x)
 534                  (unless (has-it-p x)
 535                    (or (if-let (s (find-system x))
 536                          (and (system-source-directory x)
 537                               (list s)))
 538                        (if-let (p (system-module-pathname x))
 539                          (list (make-prebuilt-system x p)))))))
 540         `((,lib-op
 541            ,@(unless (no-uiop c)
 542                (append (ensure-linkable-system "cmp")
 543                        (or (ensure-linkable-system "uiop")
 544                            (ensure-linkable-system "asdf"))))
 545            ,@deps)))))
 546
 547   (defmethod perform ((o link-op) (c system))
 548     (let* ((object-files (input-files o c))
 549            (output (output-files o c))
 550            (bundle (first output))
 551            (programp (typep o 'program-op))
 552            (kind (bundle-type o)))
 553       (when output
 554         (apply 'create-image
 555                bundle (append
 556                        (when programp (prefix-lisp-object-files c))
 557                        object-files
 558                        (when programp (postfix-lisp-object-files c)))
 559                :kind kind
 560                :prologue-code (when programp (prologue-code c))
 561                :epilogue-code (when programp (epilogue-code c))
 562                :build-args (when programp (extra-build-args c))
 563                :extra-object-files (when programp (extra-object-files c))
 564                :no-uiop (no-uiop c)
 565                (when programp `(:entry-point ,(component-entry-point c))))))))