diff --git a/asdf-bundle.asd b/asdf-bundle.asd index 7039eb1f6aff25833e377207f62c6a471e2f3c84..6bb46fb39bae77130c7651a148278a78cdbdb21e 100644 --- a/asdf-bundle.asd +++ b/asdf-bundle.asd @@ -18,9 +18,4 @@ :description "Bundle operations for ASDF" :long-description "Can bundle one or many asdf systems into one .fasl and/or one .so" :depends-on (:asdf) - :components - ((:file "specials") - (:file "bundle" :depends-on ("specials")) - #+(or allegro clisp clozure sbcl) (:file "fasl-concat" :depends-on ("bundle")) - #+ecl (:file "ecl" :depends-on ("specials")) - #+mkcl (:file "mkcl" :depends-on ("specials")))) + :components ((:file "asdf-bundle"))) diff --git a/bundle.lisp b/asdf-bundle.lisp similarity index 67% rename from bundle.lisp rename to asdf-bundle.lisp index 5b149f4f28084bc1f32d8686ab99ddcb81ba19ca..4043a4cad1af5a7e109a4b5eea8cdebc333712bc 100644 --- a/bundle.lisp +++ b/asdf-bundle.lisp @@ -25,8 +25,8 @@ (defclass bundle-op (operation) ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + (name-suffix :initarg :name-suffix :initform nil) #+ecl (type :reader bundle-op-type) - #+ecl (name-suffix :initarg :name-suffix :initform nil) #+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))) @@ -58,7 +58,6 @@ (defclass program-op (monolithic-bundle-op) ((type :initform :program))) -#+ecl (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key (name-suffix nil name-suffix-p) &allow-other-keys) @@ -73,9 +72,10 @@ (slot-value instance 'original-initargs) (setf (slot-value instance 'original-initargs) (remove-keys '(lisp-files epilogue-code prologue-code) original-initargs) - (bundle-op-lisp-files instance) lisp-files (monolithic-op-prologue-code instance) prologue-code - (monolithic-op-epilogue-code instance) epilogue-code))) + (monolithic-op-epilogue-code instance) epilogue-code) + #-ecl (assert (null lisp-files)) + #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) (setf (bundle-op-build-args instance) (remove-keys '(type monolithic name-suffix) (slot-value instance 'original-initargs)))) @@ -195,7 +195,7 @@ #|"-" (string-downcase (implementation-type))|#) :type "lisp" :defaults (system-source-directory c)) - #+ecl :type #+ecl (bundle-op-type o)))) + #+ecl :type #+ecl (bundle-op-type o)))) (defmethod perform ((o bundle-op) (c t)) (declare (ignorable o c)) @@ -403,3 +403,175 @@ :lib ,(make-pathname :name (pathname-name library) :type (pathname-type library))) s))))) + +(defun copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192)) + "Copy the contents of the INPUT stream into the OUTPUT stream, +using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver + (with-open-stream (input input) + (loop + :for buffer = (make-array (list buffer-size) :element-type element-type) + :for end = (read-sequence buffer input) + :until (zerop end) + :do (write-sequence buffer output :end end) + (when (< end buffer-size) (return))))) + +(defun concatenate-files (inputs output) + (with-open-file (o output :element-type '(unsigned-byte 8) + :direction :output :if-exists :rename-and-delete) + (dolist (input inputs) + (with-open-file (i input :element-type '(unsigned-byte 8) + :direction :input :if-does-not-exist :error) + (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + +(defun combine-fasls (inputs output) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+(or allegro clisp sbcl) (concatenate-files inputs output)) + +(defun call-with-staging-pathname (pathname fun) + "Calls fun with a staging pathname, and atomically +renames the staging pathname to the pathname in the end. +Note: this protects only against failure of the program, +not against concurrent attempts. +For the latter case, we ought pick random suffix and atomically open it." + (let* ((pathname (pathname pathname)) + (staging (make-pathname + :name (strcat (pathname-name pathname) "-ASDF-TMP") + :defaults pathname))) + (unwind-protect + (multiple-value-prog1 + (funcall fun staging) + (rename-file staging pathname #+clozure :if-exists #+clozure :rename-and-delete)) + (when (probe-file* staging) + (delete-file staging))))) + +(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) + `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) + +#-(or ecl mkcl) +(defmethod perform ((o bundle-op) (c system)) + (let* ((input-files (input-files o c)) + (fasl-files (remove (fasl-type) input-files :key #'pathname-type :test-not #'string=)) + (non-fasl-files (remove (fasl-type) input-files :key #'pathname-type :test #'string=)) + (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))) + (ensure-directories-exist output-file) + (with-staging-pathname (output-file) + (combine-fasls fasl-files output-file))))) + +(defmethod output-files ((o fasl-op) (c source-file)) + (declare (ignorable o c)) + nil) + +(defmethod input-files ((o fasl-op) (c source-file)) + (declare (ignorable o c)) + nil) + +#+ecl +(defmethod output-files ((o fasl-op) (c system)) + (declare (ignorable o c)) + (loop :for file :in (call-next-method) + :collect (make-pathname :type "fasb" :defaults file))) + +#+ecl +(defmethod perform ((o bundle-op) (c system)) + (let* ((object-files (remove "fas" (input-files o c) + :key #'pathname-type :test #'string=)) + (output (output-files o c))) + (ensure-directories-exist (first output)) + (apply #'c::builder (bundle-op-type o) (first output) + :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))) + (when (and (typep o 'monolithic-bundle-op) + (monolithic-op-epilogue-code o)) + `(:epilogue-code ,(monolithic-op-epilogue-code o))))))) + +#+mkcl +(progn +;;; +;;; BUNDLE-SUB-OPERATIONS +;;; +;;; Builds a list of pairs (operation . component) which contains all the +;;; dependencies of this bundle. +;;; + +(defun mkcl-bundle-sub-operations (sys) + (gather-components 'compile-op sys + :filter-system sys + :filter-type '(not system))) + +(defun files-to-bundle (sys) + (loop :for (op . comp) :in (mkcl-bundle-sub-operations sys) + :for sub-files = (output-files op comp) + :when sub-files + :collect (first sub-files))) + +(defmethod component-depends-on ((o bundle-op) (c system)) + (cons `(compile-op ,(component-name c)) (call-next-method))) + +(defmethod output-files ((o bundle-op) (c system)) + (let* ((name (component-name c)) + (static-lib-name (merge-pathnames + (compiler::builder-internal-pathname name :static-library) + (component-relative-pathname c))) + (fasl-bundle-name (merge-pathnames + (compiler::builder-internal-pathname name :fasb) + (component-relative-pathname c)))) + (list static-lib-name fasl-bundle-name))) + +(defmethod perform ((o bundle-op) (c system)) + (let* ((object-files (files-to-bundle c)) + (output (output-files o c))) + (ensure-directories-exist (first output)) + (when (bundle-op-do-static-library-p o) + (apply #'compiler::build-static-library (first output) + :lisp-object-files object-files (bundle-op-build-args o))) + (when (bundle-op-do-fasb-p o) + (apply #'compiler::build-bundle (second output) + :lisp-object-files object-files (bundle-op-build-args o))))) + +(defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'bundle-op system args)) + +;;; +;;; BUNDLED FILES +;;; +;;; This component can be used to distribute ASDF libraries in bundled form. +;;; + +(defclass bundle (component) ()) + +(defmethod source-file-type ((c bundle) (s system)) + "fasb") + +(defmethod perform ((o load-op) (c bundle)) + (load (component-pathname c))) + +(defmethod perform (o (c bundle)) + (declare (ignore o)) + nil) + +;; The ability to load a fasb bundle is separate from +;; the ability to build a fasb bundle, so this is somewhat unrelated to what is above. +);mkcl + +;;; +;;; Final integration steps +;;; + +(export '(load-fasl-op #+ecl make-build #+mkcl bundle-system)) + +#+(or ecl mkcl) +(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) diff --git a/build.xcvb b/build.xcvb index ab9d205aa5e289339306c1cb3823114d3ec7176d..04231480b5f672826bf0053488af12654bdf6c5e 100644 --- a/build.xcvb +++ b/build.xcvb @@ -2,10 +2,5 @@ (module (:fullname "asdf-bundle" :build-depends-on ("/asdf") - :depends-on - ("specials" - "bundle" - (:cond - ((:featurep :ecl) "ecl") - ((:featurep (:or :sbcl :clozure)) "fasl-concat"))) + :depends-on ("asdf-bundle") :supersedes-asdf ("asdf-bundle"))) diff --git a/ecl.lisp b/ecl.lisp deleted file mode 100644 index 7dc2ca4254c8131463d631ec0a4b07f2a6ff0c2a..0000000000000000000000000000000000000000 --- a/ecl.lisp +++ /dev/null @@ -1,34 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module (:depends-on ("specials"))) - -(in-package :asdf) - -(defmethod output-files ((o fasl-op) (c system)) - (declare (ignorable o c)) - (loop :for file :in (call-next-method) - :collect (make-pathname :type "fasb" :defaults file))) - -(defmethod perform ((o bundle-op) (c system)) - (let* ((object-files (remove "fas" (input-files o c) - :key #'pathname-type :test #'string=)) - (output (output-files o c))) - (ensure-directories-exist (first output)) - (apply #'c::builder (bundle-op-type o) (first output) - :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))) - (when (and (typep o 'monolithic-bundle-op) - (monolithic-op-epilogue-code o)) - `(:epilogue-code ,(monolithic-op-epilogue-code o))))))) - - -;;; -;;; Final integration steps -;;; - -(export '(make-build load-fasl-op)) - -(pushnew '("fasb" . si::load-binary) ext:*load-hooks* :test 'equal :key 'car) diff --git a/fasl-concat.lisp b/fasl-concat.lisp deleted file mode 100644 index f0dd616dff696c3f0e2ee1846d846e1343cfb003..0000000000000000000000000000000000000000 --- a/fasl-concat.lisp +++ /dev/null @@ -1,77 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module (:depends-on ("bundle"))) - -(in-package :asdf) - -(declaim (optimize (debug 3) (safety 3) (speed 1))) - -(defun copy-stream-to-stream (input output &key (element-type 'character) (buffer-size 8192)) - "Copy the contents of the INPUT stream into the OUTPUT stream, -using WRITE-SEQUENCE and a sensibly sized buffer." ; copied from xcvb-driver - (with-open-stream (input input) - (loop - :for buffer = (make-array (list buffer-size) :element-type element-type) - :for end = (read-sequence buffer input) - :until (zerop end) - :do (write-sequence buffer output :end end) - (when (< end buffer-size) (return))))) - -(defun concatenate-files (inputs output) - (with-open-file (o output :element-type '(unsigned-byte 8) - :direction :output :if-exists :rename-and-delete) - (dolist (input inputs) - (with-open-file (i input :element-type '(unsigned-byte 8) - :direction :input :if-does-not-exist :error) - (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) - -(defun combine-fasls (inputs output) - #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) - #+(or allegro clisp sbcl) (concatenate-files inputs output)) - -(defun call-with-staging-pathname (pathname fun) - "Calls fun with a staging pathname, and atomically -renames the staging pathname to the pathname in the end. -Note: this protects only against failure of the program, -not against concurrent attempts. -For the latter case, we ought pick random suffix and atomically open it." - (let* ((pathname (pathname pathname)) - (staging (make-pathname - :name (strcat (pathname-name pathname) "-staging") - :defaults pathname))) - (unwind-protect - (multiple-value-prog1 - (funcall fun staging) - (rename-file staging pathname #+clozure :if-exists #+clozure :rename-and-delete)) - (when (probe-file* staging) - (delete-file staging))))) - -(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) - `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))) - -(defmethod perform ((o bundle-op) (c system)) - (let* ((input-files (input-files o c)) - (fasl-files (remove (fasl-type) input-files :key #'pathname-type :test-not #'string=)) - (non-fasl-files (remove (fasl-type) input-files :key #'pathname-type :test #'string=)) - (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))) - (ensure-directories-exist output-file) - (with-staging-pathname (output-file) - (combine-fasls fasl-files output-file))))) - -(defmethod output-files ((o fasl-op) (c component)) - (declare (ignorable o c)) - nil) - -(defmethod input-files ((o fasl-op) (c component)) - (declare (ignorable o c)) - nil) diff --git a/mkcl.lisp b/mkcl.lisp deleted file mode 100644 index 60fc1b1bf170b6a86ffcadb8a8f0427eacddd2fb..0000000000000000000000000000000000000000 --- a/mkcl.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module (:depends-on ("specials"))) - -(in-package :asdf) - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; Make sure we have strict ANSI class redefinition semantics. - (setq clos::*redefine-class-in-place* t)) - -;;; -;;; BUNDLE-SUB-OPERATIONS -;;; -;;; Builds a list of pairs (operation . component) which contains all the -;;; dependencies of this bundle. -;;; - -(defun mkcl-bundle-sub-operations (sys) - (gather-components 'compile-op sys - :filter-system sys - :filter-type '(not system))) - -(defun files-to-bundle (sys) - (loop :for (op . comp) :in (mkcl-bundle-sub-operations sys) - :for sub-files = (output-files op comp) - :when sub-files - :collect (first sub-files))) - -(defmethod component-depends-on ((o bundle-op) (c system)) - (cons `(compile-op ,(component-name c)) (call-next-method))) - -(defmethod output-files ((o bundle-op) (c system)) - (let* ((name (component-name c)) - (static-lib-name (merge-pathnames - (compiler::builder-internal-pathname name :static-library) - (component-relative-pathname c))) - (fasl-bundle-name (merge-pathnames - (compiler::builder-internal-pathname name :fasb) - (component-relative-pathname c)))) - (list static-lib-name fasl-bundle-name))) - -(defmethod perform ((o bundle-op) (c system)) - (let* ((object-files (files-to-bundle c)) - (output (output-files o c))) - (ensure-directories-exist (first output)) - (when (bundle-op-do-static-library-p o) - (apply #'compiler::build-static-library (first output) - :lisp-object-files object-files (bundle-op-build-args o))) - (when (bundle-op-do-fasb-p o) - (apply #'compiler::build-bundle (second output) - :lisp-object-files object-files (bundle-op-build-args o))))) - -(defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) - (declare (ignore force verbose version)) - (apply #'operate 'bundle-op system args)) - -(export '(bundle-system)) - - -;;; -;;; BUNDLED FILES -;;; -;;; This component can be used to distribute ASDF libraries in bundled form. -;;; - -(defclass bundle (component) ()) - -(defmethod source-file-type ((c bundle) (s system)) - "fasb") - -(defmethod perform ((o load-op) (c bundle)) - (load (component-pathname c))) - -(defmethod perform (o (c bundle)) - (declare (ignore o)) - nil) - -;; The ability to load a fasb bundle is separate from -;; the ability to build a fasb bundle, so this is somewhat unrelated to what is above. -(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) diff --git a/specials.lisp b/specials.lisp deleted file mode 100644 index d624a337c24a8f1309ab08d1fae0bdfa283314a3..0000000000000000000000000000000000000000 --- a/specials.lisp +++ /dev/null @@ -1,5 +0,0 @@ -;;; -*- Mode: Lisp ; Syntax: ANSI-Common-Lisp -*- - -#+xcvb (module ()) - -(in-package :asdf)