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

Refactor bundle support for ECL and MKCL.

parent a2928a03
......@@ -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))))
......
......@@ -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
......
......@@ -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))
......@@ -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))))
......
......@@ -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))))
......
......@@ -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)
......
;;; -*- 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))
......
......@@ -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
......
......@@ -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
......
Supports Markdown
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