From 007f7609c3c20262bd85f6b2cc5d2aab54dedb48 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 24 Mar 2014 19:12:31 -0400 Subject: [PATCH] Refactor bundle support for ECL and MKCL. --- bundle.lisp | 157 +++++++++++++----------------- interface.lisp | 2 +- test/make-hello-world.lisp | 29 ++++-- test/test-bundle.script | 1 + test/test-encodings.script | 4 + test/test-logical-pathname.script | 4 +- test/test-program.script | 3 + test/test-utilities.script | 1 - uiop/image.lisp | 38 +++++--- 9 files changed, 119 insertions(+), 120 deletions(-) diff --git a/bundle.lisp b/bundle.lisp index 7c6204cf..582127fa 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -7,7 +7,7 @@ :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) (:export - #:bundle-op #:bundle-op-build-args #:bundle-type + #:bundle-op #:bundle-type #:program-system #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op @@ -18,17 +18,16 @@ #:deliver-asd-op #:monolithic-deliver-asd-op #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system #:user-system-p #:user-system #:trivial-system-p - #+ecl #:make-build - #:register-pre-built-system + #:make-build #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) (in-package :asdf/bundle) (with-upgradability () (defclass bundle-op (basic-compile-op) - ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + ((build-args :initarg :args :initform nil :accessor extra-build-args) (name-suffix :initarg :name-suffix :initform nil) (bundle-type :initform :no-output-file :reader bundle-type) - #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files))) + #+ecl (lisp-files :initform nil :accessor extra-object-files))) (defclass monolithic-op (operation) () (:documentation "A MONOLITHIC operation operates on a system *and all of its @@ -39,29 +38,28 @@ itself.")) ;; operation on a system and its dependencies (defclass monolithic-bundle-op (monolithic-op bundle-op) ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation - ((prologue-code :accessor prologue-code) - (epilogue-code :accessor epilogue-code))) + ((prologue-code :initform nil :accessor prologue-code) + (epilogue-code :initform nil :accessor epilogue-code))) - (defclass bundle-system (system) + (defclass program-system (system) ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system - ((prologue-code :accessor prologue-code) - (epilogue-code :accessor epilogue-code))) - - #+mkcl - (defclass program (bundle-system) - ((prologue-code :initarg :prologue-code :initform nil :accessor prologue-code) - (epilogue-code :initarg :epilogue-code :initform nil :accessor epilogue-code) + ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) + (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) (prefix-lisp-object-files :initarg :prefix-lisp-object-files - :initform nil :accessor program-prefix-lisp-object-files) + :initform nil :accessor prefix-lisp-object-files) (postfix-lisp-object-files :initarg :postfix-lisp-object-files - :initform nil :accessor program-postfix-lisp-object-files) - (object-files :initarg :object-files - :initform nil :accessor program-object-files) + :initform nil :accessor postfix-lisp-object-files) + (extra-object-files :initarg :extra-object-files + :initform nil :accessor extra-object-files) (extra-build-args :initarg :extra-build-args - :initform nil :accessor program-extra-build-args))) + :initform nil :accessor extra-build-args))) (defmethod prologue-code ((x t)) nil) (defmethod epilogue-code ((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) + (defmethod extra-build-args ((x t)) nil) (defclass link-op (bundle-op) () (:documentation "Abstract operation for linking files together")) @@ -97,7 +95,8 @@ itself.")) ;; operation on a system and its dependencies ((bundle-type :initform :lib)) (:documentation "compile the system and produce linkable (.a) library for it.")) - (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation #+ecl link-op #-ecl gather-op) + (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation + #+(or ecl mkcl) link-op #-ecl gather-op) ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class))) (defclass load-bundle-op (basic-load-op selfward-operation) @@ -123,7 +122,7 @@ itself.")) ;; operation on a system and its dependencies (:documentation "produce fasl and asd files for combined system and dependencies.")) (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op - #+ecl link-op gather-op non-propagating-operation) + #+(or ecl mkcl) link-op gather-op non-propagating-operation) ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class)) (:documentation "Create a single fasl for the system and its dependencies.")) @@ -139,7 +138,7 @@ itself.")) ;; operation on a 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 - #+ecl link-op #+(or ecl mkcl) gather-op) + #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op) ((bundle-type :initform :image) (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) @@ -217,8 +216,8 @@ itself.")) ;; operation on a system and its dependencies (setf (prologue-code instance) prologue-code (epilogue-code instance) epilogue-code) #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code))) - #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) - (setf (bundle-op-build-args instance) + #+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) (operation-original-initargs instance)))) @@ -252,11 +251,6 @@ itself.")) ;; operation on a system and its dependencies ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL ;;; (with-upgradability () - (defmethod component-depends-on :around ((o bundle-op) (c component)) - (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) - `((,op ,c)) - (call-next-method))) - (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) ;; This file selects output files from direct dependencies; ;; your component-depends-on method better gathered the correct dependencies in the correct order. @@ -283,7 +277,7 @@ itself.")) ;; operation on a system and its dependencies ((:program) 'program-op))) - ;; This is originally from asdf-ecl.lisp. Does anyone use it? + ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it? (defun make-build (system &rest args &key (monolithic nil) (type :fasl) (move-here nil move-here-p) &allow-other-keys) @@ -306,7 +300,12 @@ itself.")) ;; operation on a system and its dependencies :defaults dest-path) :do (rename-file-overwriting-target f new-f) :collect new-f) - files)))) + files))) + + ;; DEPRECATED. Does anyone use this? + (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'deliver-asd-op system args))) ;;; ;;; LOAD-BUNDLE-OP @@ -315,8 +314,7 @@ itself.")) ;; operation on a system and its dependencies ;;; (with-upgradability () (defmethod component-depends-on ((o load-bundle-op) (c system)) - `((,o ,@(loop :for dep :in (component-sideway-dependencies c) - :collect (resolve-dependency-spec c dep))) + `((,o ,@(component-sideway-dependencies c)) (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) ,@(call-next-method))) @@ -461,38 +459,37 @@ itself.")) ;; operation on a system and its dependencies (asdf:load-system :precompiled-asdf-utils) |# -#+ecl -(with-upgradability () - (defun uiop-library-file () - (or (and (find-system :uiop nil) - (system-source-directory :uiop) - (progn - (operate 'lib-op :uiop) - (output-file 'lib-op :uiop))) - (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib)))) - (defmethod input-files :around ((o program-op) (c system)) - (let ((files (call-next-method)) - (plan (traverse-sub-actions o c :plan-class 'sequential-plan))) - (unless (or (and (system-source-directory :uiop) - (plan-operates-on-p plan '("uiop"))) - (and (system-source-directory :asdf) - (plan-operates-on-p plan '("asdf")))) - (pushnew (uiop-library-file) files :test 'pathname-equal)) - files))) - #+(or ecl mkcl) (with-upgradability () - (defun register-pre-built-system (name) - (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) - -#+ecl -(with-upgradability () - ;; I think that Juanjo intended for this to be. - ;; But it might break systems with missing dependencies, - ;; and there is a weird bug in test-xach-update-bug.script - ;;(unless (use-ecl-byte-compiler-p) + ;; I think that Juanjo intended for this to be, + ;; but beware the weird bug in test-xach-update-bug.script, + ;; and also it makes mkcl fail test-logical-pathname.script, + ;; and ecl fail test-bundle.script. + ;;(unless (or #+ecl (use-ecl-byte-compiler-p)) ;; (setf *load-system-operation* 'load-bundle-op)) + (defun asdf-library-pathname () + #+ecl (compile-file-pathname "sys:asdf" :type :lib) + #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf")) + + (defun make-library-system (name pathname) + (make-instance 'prebuilt-system :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") + `(,(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")) + `(,(cond + ((system-source-directory :uiop) (find-system :uiop)) + ((system-source-directory :asdf) (find-system :asdf)) + (t (make-fake-asdf-system "asdf" (asdf-library-pathname)))))) + ,@deps))))) + (defmethod perform ((o link-op) (c system)) (let* ((object-files (input-files o c)) (output (output-files o c)) @@ -501,41 +498,17 @@ itself.")) ;; operation on a system and its dependencies (kind (bundle-type o))) (when output (apply 'create-image - bundle (append object-files (bundle-op-lisp-files o)) + bundle (append + (when programp (prefix-lisp-object-files c)) + object-files + (when programp (postfix-lisp-object-files c))) :kind kind :prologue-code (or (prologue-code o) (when programp (prologue-code c))) :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c))) - :build-args (bundle-op-build-args o) + :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))) (when programp `(:entry-point ,(component-entry-point c)))))))) -#+mkcl -(with-upgradability () - (defmethod perform ((o dll-op) (s system)) - (apply #'compiler::build-shared-library (output-file o s) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) - - (defmethod perform ((o lib-op) (s system)) - (apply #'compiler::build-static-library (output-file o s) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) - - (defmethod perform ((o basic-compile-bundle-op) (s system)) - (apply #'compiler::build-bundle (output-file o s) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) - - (defmethod perform ((o program-op) (s system)) - (apply #'compiler::build-program (output-file o s) - :lisp-object-files (append (program-prefix-lisp-object-files s) - (input-files o s) - (program-postfix-lisp-object-files s)) - :object-files (program-object-files s) - :prologue-code (prologue-code s) - :epilogue-code (epilogue-code s) - (program-extra-build-args s))) - - (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) - (declare (ignore force verbose version)) - (apply #'operate 'deliver-asd-op system args))) - #+(and (not asdf-use-unsafe-mac-bundle-op) (or (and ecl darwin) (and abcl darwin (not abcl-bundle-op-supported)))) diff --git a/interface.lisp b/interface.lisp index 02690227..13d05223 100644 --- a/interface.lisp +++ b/interface.lisp @@ -35,7 +35,7 @@ #:needed-in-image-p #:component-load-dependencies #:run-shell-command ; deprecated, do not use #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system - #+ecl #:make-build + #:program-system #:make-build #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op #:basic-compile-bundle-op #:prepare-bundle-op #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp index 48cfd706..bc312690 100644 --- a/test/make-hello-world.lisp +++ b/test/make-hello-world.lisp @@ -10,16 +10,25 @@ (asdf-test::frob-packages) -(defun make-hello-image () +#+mkcl +(defun add-mkcl-dll (pathname) + ;; make sure mkcl-X.X.X.dll is the same directory as the executable + (let* ((dll-orig (subpathname (si::self-truename) + (strcat #-windows "../lib/" + "mkcl_" (lisp-implementation-version) + "." (asdf/bundle:bundle-pathname-type :shared-library)))) + (dll-dest (subpathname pathname (strcat #-windows "../lib/" (file-namestring dll-orig))))) + (ensure-directories-exist dll-dest) + (copy-file dll-orig dll-dest))) + + +(defun make-hello-bundle (operation) (operate 'load-fasl-op :hello-world-example) - (operate 'image-op :hello-world-example)) + (operate operation :hello-world-example) + #+mkcl (add-mkcl-dll (asdf::output-file operation :hello-world-example))) + +(defun make-hello-image () + (make-hello-bundle 'image-op)) (defun make-hello-program () - (operate 'load-fasl-op :hello-world-example) - (operate 'program-op :hello-world-example) - #+(and mkcl windows) ;; make sure mkcl-X.X.X.dll is the same directory as the executable - (let* ((dll-orig (subpathname (si::self-truename) - (strcat "mkcl_" (lisp-implementation-version) ".dll"))) - (exe (asdf::output-file 'program-op :hello-world-example)) - (dll-dest (subpathname exe dll-orig))) - (copy-file dll-orig dll-dest))) + (make-hello-bundle 'program-op)) diff --git a/test/test-bundle.script b/test/test-bundle.script index da8c2658..fe30636e 100644 --- a/test/test-bundle.script +++ b/test/test-bundle.script @@ -52,6 +52,7 @@ ;;; Test dll-op and monolithic-dll-op on ECL and MKCL #+(or ecl mkcl) (progn + #+ecl (trace c::builder) (require 'sockets) ;; Test the pre-compiled system feature (operate 'dll-op :test-asdf/dll-test) (let ((dll (first (output-files 'dll-op :test-asdf/dll-test)))) diff --git a/test/test-encodings.script b/test/test-encodings.script index 0d9aa54d..5bbbb852 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -45,6 +45,10 @@ (when (version< version-nums "1.1.2") (leave-test "Your old ABCL is known to fail this test script, so skipping it." 0))) +#+mkcl +(when (version<= (lisp-implementation-version) "1.1.8") + (leave-test "Your old MKCL is known to fail this test script, so skipping it." 0)) + (with-encoding-test (:utf-8) (def-test-system :test-encoding-explicit-u8 :components ((:file "lambda" :encoding :utf-8)))) diff --git a/test/test-logical-pathname.script b/test/test-logical-pathname.script index 897877ae..b7e54e07 100644 --- a/test/test-logical-pathname.script +++ b/test/test-logical-pathname.script @@ -15,7 +15,9 @@ (DBG :logical (logical-pathname-translations "ASDF") (translate-logical-pathname "ASDF:test;test-logical-pathname.asd") - (truename "ASDF:test;test-logical-pathname.asd")) + (truename "ASDF:test;test-logical-pathname.asd") + (translate-logical-pathname "ASDF:test;test-logical-pathname.lisp") + (translate-logical-pathname "ASDF:test;test-logical-pathname.fasl")) #+(or gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0) diff --git a/test/test-program.script b/test/test-program.script index 994ca947..1f97c083 100644 --- a/test/test-program.script +++ b/test/test-program.script @@ -1,6 +1,9 @@ ;;; -*- 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)) diff --git a/test/test-utilities.script b/test/test-utilities.script index b67336f9..dae08789 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -144,7 +144,6 @@ #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition ;; on some implementations only asdf/bundle:bundle-system - asdf/bundle:register-pre-built-system asdf/bundle:static-library uiop/os:parse-file-location-info uiop/os:parse-windows-shortcut diff --git a/uiop/image.lisp b/uiop/image.lisp index 39a7066e..6c328ae8 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -416,18 +416,19 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" 'dump-image filename (nth-value 1 (implementation-type)))) - (defun create-image (destination object-files - &key kind output-name prologue-code epilogue-code + (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) - (declare (ignorable destination object-files kind output-name prologue-code epilogue-code - prelude preludep postlude postludep entry-point entry-point-p build-args)) + (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)) "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" ;; Is it meaningful to run these in the current environment? ;; only if we also track the object files that constitute the "current" image, ;; and otherwise simulate dump-image, including quitting at the end. - #-ecl (error "~S not implemented for your implementation (yet)" 'create-image) - #+ecl + #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image) + #+(or ecl mkcl) (let ((epilogue-forms (append (when epilogue-code `(,epilogue-code)) @@ -438,19 +439,26 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ((:image) (setf kind :program) ;; to ECL, it's just another program. `((setf *image-dumped-p* t) - (si::top-level t) (quit))) + (si::top-level #+ecl t) (quit))) ((:program) `((setf *image-dumped-p* :executable) (shell-boolean-exit (restore-image)))))))) - (check-type kind (member :dll :lib :static-library :program :object :fasl :program)) - (apply 'c::builder - kind (pathname destination) - :lisp-files object-files - :init-name (c::compute-init-name (or output-name destination) :kind kind) - :prologue-code prologue-code - :epilogue-code (when epilogue-forms `(progn ,@epilogue-forms)) - build-args)))) + #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl)) + (apply #+ecl 'c::builder #+ecl kind + #+mkcl (ecase kind + ((:dll) 'compiler::build-shared-library) + ((:lib :static-library) 'compiler::build-static-library) + ((:fasl) 'compiler::build-bundle) + ((:program) 'compiler::build-program)) + (pathname destination) + #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files) + #+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))) + #+mkcl (when extra-object-files `(:object-files ,extra-object-files)) + build-args))))) ;;; Some universal image restore hooks -- GitLab