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
Loading
Loading
Loading
Loading
+55 −32
Original line number Diff line number Diff line
@@ -8,7 +8,7 @@
   :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem)
  (:export
   #: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
   #:basic-compile-bundle-op #:prepare-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
    (:documentation "Abstract operation for linking files together"))

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

  (defun operation-monolithic-p (op)
@@ -86,7 +87,9 @@ itself.")) ;; operation on a system and its dependencies

  ;; create a single fasl for the entire library
  (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)
    ((sideway-operation
@@ -94,7 +97,8 @@ itself.")) ;; operation on a system and its dependencies
      :allocation :class)))

  (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.
Compare with DLL-OP."))

@@ -120,24 +124,35 @@ faster and more resource efficient."))
  ;; 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)
    ((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.
Compare with LIB-OP."))

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


  (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op)
    ((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)
      :allocation :class))
    (: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
      (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) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class))
    ((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."))

  (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op)
@@ -148,12 +163,13 @@ Compare with LIB-OP."))
    (:documentation "Create a single linkable library for the system and its dependencies."))

  (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."))

  (defclass image-op (monolithic-bundle-op selfward-operation
                      #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op)
    ((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))
    (:documentation "create an image file from the system and its dependencies"))

@@ -163,17 +179,29 @@ Compare with LIB-OP."))

  (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 clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb")
      #+(or clasp ecl)
      ((member :dll :lib :shared-library :static-library :program :object :program)
       (compile-file-type :type bundle-type))
      ((member :image) #+allegro "dxl" #+(and clisp os-windows) "exe" #-(or allegro (and clisp os-windows)) "image")
      ((member :dll :shared-library) (os-cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
      ((member :lib :static-library) (os-cond ((os-unix-p) "a")
      ((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"))))
      ((eql :program) (os-cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
      ((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)
    (let ((bundle-type (bundle-type o)))
@@ -238,16 +266,6 @@ Compare with LIB-OP."))
             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
           (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))

  (defun user-system-p (s)
@@ -276,9 +294,14 @@ Compare with LIB-OP."))
                 (loop :for f :in (funcall key sub-o sub-c)
                       :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))
    (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)
    (ecase type
+7 −1
Original line number Diff line number Diff line
@@ -89,7 +89,13 @@
               &optional
                 #+(or clasp ecl mkcl) object-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
             c #'(lambda (&rest flags)
                   (apply 'compile-file* input-file
+1 −1
Original line number Diff line number Diff line
@@ -224,7 +224,7 @@ the action of OPERATION on COMPONENT in the PLAN"))
            (latest-in (stamps-latest (cons dep-stamp in-stamps))))
       (when (and missing-in (not just-done)) (return (values t nil))))
     ;; 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))
            (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
            (earliest-out (stamps-earliest out-stamps)))
+10 −3
Original line number Diff line number Diff line
@@ -49,28 +49,35 @@
(operate 'monolithic-compile-bundle-op :test-asdf/bundle-2)
(assert (probe-file *mono-bundle-2*))

;;; Test dll-op and monolithic-dll-op on ECL and MKCL
#+(or ecl mkcl)
(progn
  (DBG "On ECL and MKCL, test dll-op and monolithic-dll-op")
  #+ecl (trace c::builder)
  (require 'sockets) ;; Test the pre-compiled system feature
  ;; Test that we didn't break require for non-asdf modules
  (DBG "Test the pre-compiled system feature")
  (require 'sockets)
  (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*)
    (require 'serve-event))
  (DBG "Create a DLL via dll-op")
  (operate 'dll-op :test-asdf/dll-test)
  (DBG "Load the DLL")
  (let ((dll (first (output-files 'dll-op :test-asdf/dll-test))))
    (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))))
      (operate 'load-op :test-asdf/dll-user)))
  (DBG "Test that the DLL works")
  (assert-equal (test-package::sample-function) 42)

  (DBG "Create a DLL via monolithic-dll-op")
  (nest
   #+(and mkcl windows)
   (let* ((lib (first (output-files (operate 'lib-op :test-asdf/monodll-1) :test-asdf/monodll-1)))
          (compiler::*builder-default-libraries* (list (namestring lib)))))
   (operate 'monolithic-dll-op :test-asdf/monodll))

  (DBG "Use and test that DLL")
  (let ((dll (first (output-files 'monolithic-dll-op :test-asdf/monodll))))
    (si:load-foreign-module dll)
    (let* (#+(and mkcl windows) (compiler::*builder-default-libraries* (list (namestring dll))))