Skip to content
Snippets Groups Projects
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
No related branches found
No related tags found
No related merge requests found
...@@ -45,6 +45,7 @@ itself.")) ;; operation on a system and its dependencies ...@@ -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 ;; 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) ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
(epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-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 (prefix-lisp-object-files :initarg :prefix-lisp-object-files
:initform nil :accessor prefix-lisp-object-files) :initform nil :accessor prefix-lisp-object-files)
(postfix-lisp-object-files :initarg :postfix-lisp-object-files (postfix-lisp-object-files :initarg :postfix-lisp-object-files
...@@ -56,6 +57,7 @@ itself.")) ;; operation on a system and its dependencies ...@@ -56,6 +57,7 @@ itself.")) ;; operation on a system and its dependencies
(defmethod prologue-code ((x t)) nil) (defmethod prologue-code ((x t)) nil)
(defmethod epilogue-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 prefix-lisp-object-files ((x t)) nil)
(defmethod postfix-lisp-object-files ((x t)) nil) (defmethod postfix-lisp-object-files ((x t)) nil)
(defmethod extra-object-files ((x t)) nil) (defmethod extra-object-files ((x t)) nil)
...@@ -219,7 +221,8 @@ itself.")) ;; operation on a system and its dependencies ...@@ -219,7 +221,8 @@ itself.")) ;; operation on a system and its dependencies
#+ecl (setf (extra-object-files instance) lisp-files))) #+ecl (setf (extra-object-files instance) lisp-files)))
(setf (extra-build-args instance) (setf (extra-build-args instance)
(remove-plist-keys (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)))) (operation-original-initargs instance))))
(defun bundlable-file-p (pathname) (defun bundlable-file-p (pathname)
...@@ -469,25 +472,29 @@ itself.")) ;; operation on a system and its dependencies ...@@ -469,25 +472,29 @@ itself.")) ;; operation on a system and its dependencies
;; (setf *load-system-operation* 'load-bundle-op)) ;; (setf *load-system-operation* 'load-bundle-op))
(defun asdf-library-pathname () (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")) #+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) (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)) (defmethod component-depends-on :around ((o image-op) (c system))
(destructuring-bind ((lib-op . deps)) (call-next-method) (destructuring-bind ((lib-op . deps)) (call-next-method)
(flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))) (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
`((,lib-op `((,lib-op
#+mkcl ,@(unless (has-it-p "cmp") ,@(unless (or (no-uiop c) (has-it-p "cmp"))
`(,(make-library-system `(,(make-library-system
"cmp" (make-pathname :type (bundle-pathname-type :lib) "cmp" (compiler-library-pathname))))
:defaults #p"sys:cmp")))) ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
,@(unless (or (has-it-p "asdf") (has-it-p "uiop"))
`(,(cond `(,(cond
((system-source-directory :uiop) (find-system :uiop)) ((system-source-directory :uiop) (find-system :uiop))
((system-source-directory :asdf) (find-system :asdf)) ((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))))) ,@deps)))))
(defmethod perform ((o link-op) (c system)) (defmethod perform ((o link-op) (c system))
...@@ -507,6 +514,7 @@ itself.")) ;; operation on a system and its dependencies ...@@ -507,6 +514,7 @@ itself.")) ;; operation on a system and its dependencies
:epilogue-code (or (epilogue-code o) (when programp (epilogue-code c))) :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c)))
:build-args (or (extra-build-args o) (when programp (extra-build-args 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))) :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)))))))) (when programp `(:entry-point ,(component-entry-point c))))))))
#+(and (not asdf-use-unsafe-mac-bundle-op) #+(and (not asdf-use-unsafe-mac-bundle-op)
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
(DBG :foo (current-lisp-file-pathname)) (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) (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") (DBG "Creating images is not supported on your CL implementation")
(leave-test "Skipping test" 0)) (leave-test "Skipping test" 0))
...@@ -112,4 +109,25 @@ ...@@ -112,4 +109,25 @@
" \"b c\"" " \"b c\""
" \"d\"")) " \"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. ;;; TODO: include a regular system dependency and a prebuilt-system in the executable.
...@@ -419,7 +419,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ...@@ -419,7 +419,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
(defun create-image (destination lisp-object-files (defun create-image (destination lisp-object-files
&key kind output-name prologue-code epilogue-code extra-object-files &key kind output-name prologue-code epilogue-code extra-object-files
(prelude () preludep) (postlude () postludep) (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 (declare (ignorable destination lisp-object-files extra-object-files kind output-name
prologue-code epilogue-code prelude preludep postlude postludep prologue-code epilogue-code prelude preludep postlude postludep
entry-point entry-point-p build-args)) entry-point entry-point-p build-args))
...@@ -429,21 +429,25 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ...@@ -429,21 +429,25 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows."
;; and otherwise simulate dump-image, including quitting at the end. ;; 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) (error "~S not implemented for your implementation (yet)" 'create-image)
#+(or ecl mkcl) #+(or ecl mkcl)
(let ((epilogue-forms (let ((epilogue-code
(append (if no-uiop
(when epilogue-code `(,epilogue-code)) epilogue-code
(when postludep `((setf *image-postlude* ',postlude))) (let ((forms
(when preludep `((setf *image-prelude* ',prelude))) (append
(when entry-point-p `((setf *image-entry-point* ',entry-point))) (when epilogue-code `(,epilogue-code))
(case kind (when postludep `((setf *image-postlude* ',postlude)))
((:image) (when preludep `((setf *image-prelude* ',prelude)))
(setf kind :program) ;; to ECL, it's just another program. (when entry-point-p `((setf *image-entry-point* ',entry-point)))
`((setf *image-dumped-p* t) (case kind
(si::top-level #+ecl t) (quit))) ((:image)
((:program) (setf kind :program) ;; to ECL, it's just another program.
`((setf *image-dumped-p* :executable) `((setf *image-dumped-p* t)
(shell-boolean-exit (si::top-level #+ecl t) (quit)))
(restore-image)))))))) ((:program)
`((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)) #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
(apply #+ecl 'c::builder #+ecl kind (apply #+ecl 'c::builder #+ecl kind
#+mkcl (ecase kind #+mkcl (ecase kind
...@@ -456,7 +460,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ...@@ -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) #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind)
(append (append
(when prologue-code `(:prologue-code ,prologue-code)) (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)) #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
build-args))))) build-args)))))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment