steps towards a recursive ASDF
Andreas Fuchs <[email protected]>
| Newsgroups | gmane.lisp.cclan.general |
|---|---|
| Message-ID | <87r7dg2rsa.wl%[email protected]> |
Hi,
Short story: Dan and I talked about this in Amsterdam, and I promised
to send a patch, so here it is.
Longer story:
The time when a module's (and a system's) PERFORM method is called is
not really intuitive. Many people (me included (-:) seem to think that
a module's components' PERFORM method should be called in the dynamic
extent of the module's PERFORM method. This is not currently the
case. Instead, ADSF's TRAVERSE method orders the steps required to
perform an operation on a component like this:
1. the steps needed to build the component's dependencies
2. the steps needed to build the component's sub-components (if
the component is a module)
3. a step calling PERFORM on the (component, operation) pair itself.
In that setup, it's impossible to wrap a system's components in
dynamic-extent things while an operation is running, e.g. to use
with-compilation-unit options or to add a handler for conditions.
This patch changes the order of things slightly. The planning stage is
not eliminated, but the result from TRAVERSE is slightly different. It
returns a linear list as before, but it contains only the steps needed
to build the component's dependencies and the call to the component's
PERFORM method itself. TRAVERSE adds to modules it encounters a list
of steps from 2. above. A PERFORM method specialized on modules
performs the steps necessary to build each module's sub-components.
Example usage from the CLX .asd file:
instead of specializing PERFORM on clx-source-file and using
:clx-source-file components throughout, it could be possible to use
:file components and use this method instead:
(defmethod perform :around ((o compile-op) (f (eql (find-system :clx))))
;; our CLX library should compile without WARNINGs, and ideally
;; without STYLE-WARNINGs. Since it currently does, let's enforce
;; it here so that we can catch regressions easily.
(let ((on-warnings (operation-on-warnings o))
(on-failure (operation-on-failure o)))
(unwind-protect
(progn
(setf (operation-on-warnings o) :error
(operation-on-failure o) :error)
;; a variety of accessors, such as AREF-CARD32, are not
;; declared INLINE. Without this (non-ANSI)
;; static-type-inference behaviour, SBCL emits an extra 100
;; optimization notes (roughly one fifth of all of the
;; notes emitted). Since the internals are unlikely to
;; change much, and certainly the internals should stay in
;; sync, enabling this extension is a win. (Note that the
;; use of this does not imply that applications using CLX
;; calls that expand into calls to these accessors will be
;; optimized in the same way).
(let ((sb-ext:*derive-function-types* t))
;; deeply unportable stuff, this. I will be shot. We
;; want to enable the dynamic-extent declarations in CLX.
(when (sb-c::policy-quality-name-p
'sb-c::stack-allocate-dynamic-extent)
;; no way of setting it back short of yet more yukky stuff
(proclaim '(optimize (sb-c::stack-allocate-dynamic-extent 3))))
(call-next-method)))
(setf (operation-on-warnings o) on-warnings
(operation-on-failure o) on-failure))))
So, without further ado, here's the patch:
Have fun,
--
Andreas Fuchs, <[email protected]>, [email protected], antifuchs
,recursive-asdf.patch
(application/octet-stream, 6.8 KB)
* looking for [email protected]/sbcl--main--0.9--patch-165 to compare with * comparing to [email protected]/sbcl--main--0.9--patch-165 M contrib/asdf/asdf.lisp * modified files --- orig/contrib/asdf/asdf.lisp +++ mod/contrib/asdf/asdf.lisp @@ -237,6 +237,8 @@ (if-component-dep-fails :initform :fail :accessor module-if-component-dep-fails :initarg :if-component-dep-fails) + (component-ops :initform (make-hash-table :test #'eql) + :accessor module-component-ops :initarg :component-ops) (default-component-class :accessor module-default-component-class :initform 'cl-source-file :initarg :default-component-class))) @@ -632,41 +634,40 @@ (loop for (required-op . deps) in (component-depends-on operation c) do (do-dep required-op deps)) ;; constituent bits - (let ((module-ops - (when (typep c 'module) - (let ((at-least-one nil) - (forced nil) - (error nil)) - (loop for kid in (module-components c) - do (handler-case - (appendf forced (traverse operation kid )) - (missing-dependency (condition) - (if (eq (module-if-component-dep-fails c) :fail) - (error condition)) - (setf error condition)) - (:no-error (c) - (declare (ignore c)) - (setf at-least-one t)))) - (when (and (eq (module-if-component-dep-fails c) :try-next) - (not at-least-one)) - (error error)) - forced)))) - ;; now the thing itself - (when (or forced module-ops - (not (operation-done-p operation c)) - (let ((f (operation-forced (operation-ancestor operation)))) - (and f (or (not (consp f)) - (member (component-name - (operation-ancestor operation)) - (mapcar #'coerce-name f) - :test #'string=))))) - (let ((do-first (cdr (assoc (class-name (class-of operation)) - (slot-value c 'do-first))))) - (loop for (required-op . deps) in do-first - do (do-dep required-op deps))) - (setf forced (append (delete 'pruned-op forced :key #'car) - (delete 'pruned-op module-ops :key #'car) - (list (cons operation c)))))) + (when (typep c 'module) + (let ((at-least-one nil) + (forced nil) + (error nil)) + (loop for kid in (module-components c) + do (handler-case + (appendf forced (traverse operation kid)) + (missing-dependency (condition) + (if (eq (module-if-component-dep-fails c) :fail) + (error condition)) + (setf error condition)) + (:no-error (c) + (declare (ignore c)) + (setf at-least-one t)))) + (when (and (eq (module-if-component-dep-fails c) :try-next) + (not at-least-one)) + (error error)) + (setf (gethash operation (module-component-ops c)) + (delete 'pruned-op forced :key #'car)))) + ;; now the thing itself + (when (or forced (typep c 'module) + (not (operation-done-p operation c)) + (let ((f (operation-forced (operation-ancestor operation)))) + (and f (or (not (consp f)) + (member (component-name + (operation-ancestor operation)) + (mapcar #'coerce-name f) + :test #'string=))))) + (let ((do-first (cdr (assoc (class-name (class-of operation)) + (slot-value c 'do-first))))) + (loop for (required-op . deps) in do-first + do (do-dep required-op deps))) + (setf forced (append (delete 'pruned-op forced :key #'car) + (list (cons operation c))))) (setf (visiting-component operation c) nil) (visit-component operation c (and forced t)) forced))) @@ -679,7 +680,8 @@ (class-of operation) (class-of c))) (defmethod perform ((operation operation) (c module)) - nil) + ;; Traverse module components + (perform-steps (gethash operation (module-component-ops c)))) (defmethod explain ((operation operation) (component component)) (format *verbose-out* "~&;;; ~A on ~A~%" operation component)) @@ -805,28 +807,31 @@ (make-broadcast-stream))) (system (if (typep system 'component) system (find-system system))) (steps (traverse op system))) - (with-compilation-unit () - (loop for (op . component) in steps do - (loop - (restart-case - (progn (perform op component) - (return)) - (retry () - :report - (lambda (s) - (format s "~@<Retry performing ~S on ~S.~@:>" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@<Continue, treating ~S on ~S as ~ + (perform-steps steps))) + +(defun perform-steps (steps) + (with-compilation-unit () + (loop for (op . component) in steps do + (loop + (restart-case + (progn (perform op component) + (return)) + (retry () + :report + (lambda (s) + (format s "~@<Retry performing ~S on ~S.~@:>" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@<Continue, treating ~S on ~S as ~ having been successful.~@:>" - op component)) - (setf (gethash (type-of op) - (component-operation-times component)) - (get-universal-time)) - (return)))))))) + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))) (defun oos (&rest args) "Alias of OPERATE function"