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

Add option on ECL and MKCL to build images without UIOP, plus test.

parent e2751f31
Loading
Loading
Loading
Loading
+17 −9
Original line number Diff line number Diff line
@@ -45,6 +45,7 @@ itself.")) ;; operation on a system and its dependencies
    ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system
    ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
     (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
     (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
     (prefix-lisp-object-files :initarg :prefix-lisp-object-files
                               :initform nil :accessor prefix-lisp-object-files)
     (postfix-lisp-object-files :initarg :postfix-lisp-object-files
@@ -56,6 +57,7 @@ itself.")) ;; operation on a system and its dependencies

  (defmethod prologue-code ((x t)) nil)
  (defmethod epilogue-code ((x t)) nil)
  (defmethod no-uiop ((x t)) nil)
  (defmethod prefix-lisp-object-files ((x t)) nil)
  (defmethod postfix-lisp-object-files ((x t)) nil)
  (defmethod extra-object-files ((x t)) nil)
@@ -219,7 +221,8 @@ itself.")) ;; operation on a system and its dependencies
        #+ecl (setf (extra-object-files instance) lisp-files)))
    (setf (extra-build-args instance)
          (remove-plist-keys
           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files)
           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
             :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)
@@ -469,25 +472,29 @@ itself.")) ;; operation on a system and its dependencies
  ;;  (setf *load-system-operation* 'load-bundle-op))

  (defun asdf-library-pathname ()
    #+ecl (compile-file-pathname "sys:asdf" :type :lib)
    #+ecl (compile-file-pathname "sys:asdf" :type :object)
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))

  (defun compiler-library-pathname ()
    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))

  (defun make-library-system (name pathname)
    (make-instance 'prebuilt-system :name name :static-library (resolve-symlinks* pathname)))
    (make-instance 'prebuilt-system
                   :name (coerce-name name) :static-library (resolve-symlinks* pathname)))

  (defmethod component-depends-on :around ((o image-op) (c system))
    (destructuring-bind ((lib-op . deps)) (call-next-method)
      (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
        `((,lib-op
           #+mkcl ,@(unless (has-it-p "cmp")
           ,@(unless (or (no-uiop c) (has-it-p "cmp"))
               `(,(make-library-system
                          "cmp" (make-pathname :type (bundle-pathname-type :lib)
                                               :defaults #p"sys:cmp"))))
           ,@(unless (or (has-it-p "asdf") (has-it-p "uiop"))
                   "cmp" (compiler-library-pathname))))
           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
               `(,(cond
                    ((system-source-directory :uiop) (find-system :uiop))
                    ((system-source-directory :asdf) (find-system :asdf))
                    (t (make-fake-asdf-system "asdf" (asdf-library-pathname))))))
                    (t (make-library-system "asdf" (asdf-library-pathname))))))
           ,@deps)))))

  (defmethod perform ((o link-op) (c system))
@@ -507,6 +514,7 @@ itself.")) ;; operation on a system and its dependencies
               :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
               :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
               :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
               :no-uiop (no-uiop c)
               (when programp `(:entry-point ,(component-entry-point c))))))))

#+(and (not asdf-use-unsafe-mac-bundle-op)
+21 −3
Original line number Diff line number Diff line
;;; -*- Lisp -*-
(DBG :foo (current-lisp-file-pathname))

#+mkcl (trace perform create-image component-depends-on) ;; compiler::build-shared-library compiler::build-static-library compiler::build-bundle compiler::build-program
#+ecl (trace perform create-image c::builder component-depends-on)

(unless (or #+(or allegro clisp clozure cmu (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl scl) t)
  (DBG "Creating images is not supported on your CL implementation")
  (leave-test "Skipping test" 0))
@@ -112,4 +109,25 @@
                "  \"b c\""
                "  \"d\""))

#+(or ecl mkcl)
(progn
  (DBG "Now create an program without UIOP")
  (assert (probe-file (asdf/bundle::asdf-library-pathname)))
  (assert (probe-file (asdf/bundle::compiler-library-pathname)))
  (def-test-system hello-no-uiop
    :class program-system
    :no-uiop t
    :components ((:file "file1"))
    :epilogue-code
    (progn
      (format t "~:[Look ma, no UIOP~;Oops, UIOP~]!~%" (find-package :uiop))
      (format t "~:[But no TEST-PACKAGE :-(~;But TEST-PACKAGE~]!~%" (find-package :test-package))
      #+ecl (si:quit 0) #+mkcl (mk-ext:quit :exit-code 0)))
  (operate 'program-op 'hello-no-uiop :force t)
  (DBG :run (output-file 'program-op 'hello-no-uiop))
  (assert-equal
   (run-program `(,(native-namestring (output-file 'program-op 'hello-no-uiop)))
                :output :lines :error-output t)
   '("Look ma, no UIOP!" "But TEST-PACKAGE!")))

;;; TODO: include a regular system dependency and a prebuilt-system in the executable.
+21 −17
Original line number Diff line number Diff line
@@ -419,7 +419,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
  (defun create-image (destination lisp-object-files
                       &key kind output-name prologue-code epilogue-code extra-object-files
                         (prelude () preludep) (postlude () postludep)
                         (entry-point () entry-point-p) build-args)
                         (entry-point () entry-point-p) build-args no-uiop)
    (declare (ignorable destination lisp-object-files extra-object-files kind output-name
                        prologue-code epilogue-code prelude preludep postlude postludep
                        entry-point entry-point-p build-args))
@@ -429,7 +429,10 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
    ;; and otherwise simulate dump-image, including quitting at the end.
    #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
    #+(or ecl mkcl)
    (let ((epilogue-forms
    (let ((epilogue-code
            (if no-uiop
                epilogue-code
                (let ((forms
                        (append
                         (when epilogue-code `(,epilogue-code))
                         (when postludep `((setf *image-postlude* ',postlude)))
@@ -444,6 +447,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
                            `((setf *image-dumped-p* :executable)
                              (shell-boolean-exit
                               (restore-image))))))))
                  (when forms `(progn ,@forms))))))
      #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
      (apply #+ecl 'c::builder #+ecl kind
             #+mkcl (ecase kind
@@ -456,7 +460,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
             #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
             (append
              (when prologue-code `(:prologue-code ,prologue-code))
              (when epilogue-forms `(:epilogue-code (progn ,@epilogue-forms)))
              (when epilogue-code `(:epilogue-code ,epilogue-code))
              #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
              build-args)))))