Commit 74ea3126 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Debug bundle ops for image-based CLs

{,monolithic}{lib,dll}-op used to only work on ECL, MKCL.
Now they will work on SBCL and other image-based CLs,
though it currently requires a patched CFFI.
parent 076fea7a
...@@ -8,7 +8,7 @@ ...@@ -8,7 +8,7 @@
:asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
(:export (:export
#:bundle-op #:bundle-type #:program-system #:bundle-op #:bundle-type #:program-system
#:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files #:bundle-system #:bundle-pathname-type #:direct-dependency-files
#:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
#:basic-compile-bundle-op #:prepare-bundle-op #:basic-compile-bundle-op #:prepare-bundle-op
#:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op
...@@ -66,7 +66,8 @@ itself.")) ;; operation on a system and its dependencies ...@@ -66,7 +66,8 @@ itself.")) ;; operation on a system and its dependencies
(:documentation "Abstract operation for linking files together")) (:documentation "Abstract operation for linking files together"))
(defclass gather-op (bundle-op) (defclass gather-op (bundle-op)
((gather-op :initform nil :allocation :class :reader gather-op)) ((gather-op :initform nil :allocation :class :reader gather-op)
(gather-type :initform :no-output-file :allocation :class :reader gather-type))
(:documentation "Abstract operation for gathering many input files from a system")) (:documentation "Abstract operation for gathering many input files from a system"))
(defun operation-monolithic-p (op) (defun operation-monolithic-p (op)
...@@ -86,7 +87,9 @@ itself.")) ;; operation on a system and its dependencies ...@@ -86,7 +87,9 @@ itself.")) ;; operation on a system and its dependencies
;; create a single fasl for the entire library ;; create a single fasl for the entire library
(defclass basic-compile-bundle-op (bundle-op) (defclass basic-compile-bundle-op (bundle-op)
((bundle-type :initform :fasl))) ((gather-type :initform #-(or clasp ecl mkcl) :fasl #+(or clasp ecl mkcl) :object
:allocation :class)
(bundle-type :initform :fasl :allocation :class)))
(defclass prepare-bundle-op (sideway-operation) (defclass prepare-bundle-op (sideway-operation)
((sideway-operation ((sideway-operation
...@@ -94,7 +97,8 @@ itself.")) ;; operation on a system and its dependencies ...@@ -94,7 +97,8 @@ itself.")) ;; operation on a system and its dependencies
:allocation :class))) :allocation :class)))
(defclass lib-op (link-op gather-op non-propagating-operation) (defclass lib-op (link-op gather-op non-propagating-operation)
((bundle-type :initform :lib)) ((gather-type :initform :object :allocation :class)
(bundle-type :initform :lib :allocation :class))
(:documentation "Compile the system and produce linkable (.a) library for it. (:documentation "Compile the system and produce linkable (.a) library for it.
Compare with DLL-OP.")) Compare with DLL-OP."))
...@@ -120,24 +124,35 @@ faster and more resource efficient.")) ...@@ -120,24 +124,35 @@ faster and more resource efficient."))
;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above. ;; but instead inherit from a basic-FOO-op as with basic-compile-bundle-op above.
(defclass dll-op (link-op gather-op non-propagating-operation) (defclass dll-op (link-op gather-op non-propagating-operation)
((bundle-type :initform :dll)) ((gather-type :initform :object :allocation :class)
(bundle-type :initform :dll :allocation :class))
(:documentation "compile the system and produce dynamic (.so/.dll) library for it. (:documentation "compile the system and produce dynamic (.so/.dll) library for it.
Compare with LIB-OP.")) Compare with LIB-OP."))
(defclass deliver-asd-op (basic-compile-op selfward-operation) (defclass deliver-asd-op (basic-compile-op selfward-operation)
((selfward-operation :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class)) ((selfward-operation
;; TODO: implement link-op on all implementations, and make that
;; '(compile-bundle-op lib-op #-(or clasp ecl mkcl) dll-op)
:initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op)
:allocation :class))
(:documentation "produce an asd file for delivering the system as a single fasl")) (:documentation "produce an asd file for delivering the system as a single fasl"))
(defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op) (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
((selfward-operation ((selfward-operation
;; TODO: implement link-op on all implementations, and make that
;; '(monolithic-compile-bundle-op monolithic-lib-op #-(or clasp ecl mkcl) monolithic-dll-op)
:initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op)
:allocation :class)) :allocation :class))
(:documentation "produce fasl and asd files for combined system and dependencies.")) (:documentation "produce fasl and asd files for combined system and dependencies."))
(defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op (defclass monolithic-compile-bundle-op
#+(or clasp ecl mkcl) link-op gather-op non-propagating-operation) (monolithic-bundle-op basic-compile-bundle-op
((gather-op :initform #+(or clasp ecl mkcl) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class)) #+(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))
(:documentation "Create a single fasl for the system and its dependencies.")) (:documentation "Create a single fasl for the system and its dependencies."))
(defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op) (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
...@@ -148,12 +163,13 @@ Compare with LIB-OP.")) ...@@ -148,12 +163,13 @@ Compare with LIB-OP."))
(:documentation "Create a single linkable library for the system and its dependencies.")) (:documentation "Create a single linkable library for the system and its dependencies."))
(defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation) (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation)
((bundle-type :initform :dll)) ((gather-type :initform :static-library :allocation :class))
(:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
(defclass image-op (monolithic-bundle-op selfward-operation (defclass image-op (monolithic-bundle-op selfward-operation
#+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op) #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
((bundle-type :initform :image) ((bundle-type :initform :image)
#+(or clasp ecl mkcl) (gather-type :initform :static-library :allocation :class)
(selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class))
(:documentation "create an image file from the system and its dependencies")) (:documentation "create an image file from the system and its dependencies"))
...@@ -163,17 +179,29 @@ Compare with LIB-OP.")) ...@@ -163,17 +179,29 @@ Compare with LIB-OP."))
(defun bundle-pathname-type (bundle-type) (defun bundle-pathname-type (bundle-type)
(etypecase bundle-type (etypecase bundle-type
((eql :no-output-file) nil) ;; should we error out instead? ((or null string) ;; pass through nil or string literal
((or null string) bundle-type) bundle-type)
((eql :fasl) #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb") ((eql :no-output-file) ;; marker for a bundle-type that has NO output file
#+(or clasp ecl) (error "No output file, therefore no pathname type"))
((member :dll :lib :shared-library :static-library :program :object :program) ((eql :fasl) ;; the type of a fasl
(compile-file-type :type bundle-type)) #-(or clasp ecl mkcl) (compile-file-type) ; on image-based platforms, used as input and output
((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image") #+(or clasp ecl mkcl) "fasb") ; on C-linking platforms, only used as output for system bundles
((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) ((member :image)
((member :lib :static-library) (os-cond ((os-unix-p) "a") #+allegro "dxl"
((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) #+(and clisp os-windows) "exe"
((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "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")))))
(defun bundle-output-files (o c) (defun bundle-output-files (o c)
(let ((bundle-type (bundle-type o))) (let ((bundle-type (bundle-type o)))
...@@ -238,16 +266,6 @@ Compare with LIB-OP.")) ...@@ -238,16 +266,6 @@ Compare with LIB-OP."))
:force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
(operation-original-initargs instance)))) (operation-original-initargs instance))))
(defun bundlable-file-p (pathname)
(let ((type (pathname-type pathname)))
(declare (ignorable type))
(or #+(or clasp ecl) (or (equalp type (compile-file-type :type :object))
(equalp type (compile-file-type :type :static-library)))
#+mkcl (or (equalp type (compile-file-type :fasl-p nil))
#+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW
#+(and windows (not (or mingw32 mingw64))) (equalp type "lib"))
#+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
(defgeneric* (trivial-system-p) (component)) (defgeneric* (trivial-system-p) (component))
(defun user-system-p (s) (defun user-system-p (s)
...@@ -276,9 +294,14 @@ Compare with LIB-OP.")) ...@@ -276,9 +294,14 @@ Compare with LIB-OP."))
(loop :for f :in (funcall key sub-o sub-c) (loop :for f :in (funcall key sub-o sub-c)
:when (funcall test f) :do (collect f)))))) :when (funcall test f) :do (collect f))))))
(defun pathname-type-equal-function (type)
#'(lambda (p) (equal (pathname-type p) type)))
(defmethod input-files ((o gather-op) (c system)) (defmethod input-files ((o gather-op) (c system))
(unless (eq (bundle-type o) :no-output-file) (unless (eq (bundle-type o) :no-output-file)
(direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) (direct-dependency-files
o c :key 'output-files
:test (pathname-type-equal-function (bundle-pathname-type (gather-type o))))))
(defun select-bundle-operation (type &optional monolithic) (defun select-bundle-operation (type &optional monolithic)
(ecase type (ecase type
......
...@@ -89,7 +89,13 @@ ...@@ -89,7 +89,13 @@
&optional &optional
#+(or clasp ecl mkcl) object-file #+(or clasp ecl mkcl) object-file
#+clisp lib-file #+clisp lib-file
warnings-file) outputs warnings-file &rest rest) outputs
;; Allow for extra outputs that are not of type warnings-file
;; The way we do it is kludgy. In ASDF4, output-files shall not be positional.
(declare (ignore rest))
(when warnings-file
(unless (equal (pathname-type warnings-file) (warnings-file-type))
(setf warnings-file nil)))
(call-with-around-compile-hook (call-with-around-compile-hook
c #'(lambda (&rest flags) c #'(lambda (&rest flags)
(apply 'compile-file* input-file (apply 'compile-file* input-file
......
...@@ -224,7 +224,7 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -224,7 +224,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
(latest-in (stamps-latest (cons dep-stamp in-stamps)))) (latest-in (stamps-latest (cons dep-stamp in-stamps))))
(when (and missing-in (not just-done)) (return (values t nil)))) (when (and missing-in (not just-done)) (return (values t nil))))
;; collect timestamps from outputs, and exit early if any is missing ;; collect timestamps from outputs, and exit early if any is missing
(let* ((out-files (output-files o c)) (let* ((out-files (remove-if 'null (output-files o c)))
(out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
(missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
(earliest-out (stamps-earliest out-stamps))) (earliest-out (stamps-earliest out-stamps)))
......
...@@ -49,28 +49,35 @@ ...@@ -49,28 +49,35 @@
(operate 'monolithic-compile-bundle-op :test-asdf/bundle-2) (operate 'monolithic-compile-bundle-op :test-asdf/bundle-2)
(assert (probe-file *mono-bundle-2*)) (assert (probe-file *mono-bundle-2*))
;;; Test dll-op and monolithic-dll-op on ECL and MKCL
#+(or ecl mkcl) #+(or ecl mkcl)
(progn (progn
(DBG "On ECL and MKCL, test dll-op and monolithic-dll-op")
#+ecl (trace c::builder) #+ecl (trace c::builder)
(require 'sockets) ;; Test the pre-compiled system feature (DBG "Test the pre-compiled system feature")
;; Test that we didn't break require for non-asdf modules (require 'sockets)
(progn (progn
(DBG "Test that we didn't break require for non-asdf modules")
(pop #+ecl ext:*module-provider-functions* #+mkcl mk-ext:*module-provider-functions*) (pop #+ecl ext:*module-provider-functions* #+mkcl mk-ext:*module-provider-functions*)
(require 'serve-event)) (require 'serve-event))
(DBG "Create a DLL via dll-op")
(operate 'dll-op :test-asdf/dll-test) (operate 'dll-op :test-asdf/dll-test)
(DBG "Load the DLL")
(let ((dll (first (output-files 'dll-op :test-asdf/dll-test)))) (let ((dll (first (output-files 'dll-op :test-asdf/dll-test))))
(si:load-foreign-module dll) (si:load-foreign-module dll)
(DBG "Load a library that knows how to use the DLL")
(let* (#+(and mkcl windows) (compiler::*builder-default-libraries* (list (namestring dll)))) (let* (#+(and mkcl windows) (compiler::*builder-default-libraries* (list (namestring dll))))
(operate 'load-op :test-asdf/dll-user))) (operate 'load-op :test-asdf/dll-user)))
(DBG "Test that the DLL works")
(assert-equal (test-package::sample-function) 42) (assert-equal (test-package::sample-function) 42)
(DBG "Create a DLL via monolithic-dll-op")
(nest (nest
#+(and mkcl windows) #+(and mkcl windows)
(let* ((lib (first (output-files (operate 'lib-op :test-asdf/monodll-1) :test-asdf/monodll-1))) (let* ((lib (first (output-files (operate 'lib-op :test-asdf/monodll-1) :test-asdf/monodll-1)))
(compiler::*builder-default-libraries* (list (namestring lib))))) (compiler::*builder-default-libraries* (list (namestring lib)))))
(operate 'monolithic-dll-op :test-asdf/monodll)) (operate 'monolithic-dll-op :test-asdf/monodll))
(DBG "Use and test that DLL")
(let ((dll (first (output-files 'monolithic-dll-op :test-asdf/monodll)))) (let ((dll (first (output-files 'monolithic-dll-op :test-asdf/monodll))))
(si:load-foreign-module dll) (si:load-foreign-module dll)
(let* (#+(and mkcl windows) (compiler::*builder-default-libraries* (list (namestring dll)))) (let* (#+(and mkcl windows) (compiler::*builder-default-libraries* (list (namestring dll))))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment