From 65be1c3828ffb4e43dbdda03cd231aedcb8d486f Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Tue, 1 Jan 2013 00:46:57 -0500 Subject: [PATCH] 2.26.46: only do things in-image if needed. This restores the feature of do-first that was lost while refactoring ASDF to fix the timestamp propagation issue. The old asdf-bundle worked implicitly because of do-first: fasl-op DEPENDS-ON compile-op, and compile-op has a DO-FIRST on the load-op of dependencies, NOT a DEPENDS-ON, so if the compile-op is "done" (which did NOT check the timestamps of dependencies), then the dofirst is never consulted and load-op is never traversed. In our new ASDF, we want to always traverse the load-op of dependencies, so we can propagate their timestamps; however, we still want to only actually load them if they are needed. Therefore, visiting actions takes an additional flag "needed in this image", and each visited action can be planned or not planned yet, and a not planned yet action can be visited a second time to plan it after recursively visiting its dependencies with the "needed" flag set. Tests were fixed now to work now that this distinction exists. --- asdf.asd | 2 +- asdf.lisp | 131 +++++++++++++++++++++---------- test/test-missing-lisp-file.asd | 4 +- test/test-samedir-modules.asd | 4 +- test/test-samedir-modules.script | 7 +- test/test1.asd | 4 +- test/test1.script | 6 +- test/test2.asd | 3 +- test/test2.script | 14 ++-- test/test2a.asd | 7 +- test/test2b1.asd | 3 +- test/test2b2.asd | 3 +- test/test2b3.asd | 3 +- 13 files changed, 119 insertions(+), 72 deletions(-) diff --git a/asdf.asd b/asdf.asd index 60d99463..64417241 100644 --- a/asdf.asd +++ b/asdf.asd @@ -14,7 +14,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "2.26.45" ;; to be automatically updated by bin/bump-revision + :version "2.26.46" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:file "asdf"))) diff --git a/asdf.lisp b/asdf.lisp index 85522aaf..96c804a1 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,5 +1,5 @@ ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- -;;; This is ASDF 2.26.45: Another System Definition Facility. +;;; This is ASDF 2.26.46: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -118,7 +118,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.26.45") + (asdf-version "2.26.46") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -1154,22 +1154,12 @@ the head of the tree")) (defgeneric* component-visited-p (operation component) ;; ASDF3: rename to action-visited-p (:documentation "Returns the data stored by a call to MARK-COMPONENT-VISITED, if that has been called, otherwise NIL. -This data value will be a CONS cell, the CAR of which is a STAMP -of the status of the action, which is T if it has to be performed again; -the CDR will be a count of nodes visited before this one, useful for sorting.")) - -(defgeneric* mark-component-visited (operation component data) - (:documentation "Record DATA as being associated with OPERATION -and COMPONENT. This is a side-effecting function: the association -will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the -OPERATION\). - No evidence that DATA is ever interesting, beyond just being -non-NIL. Using the data field is probably very risky; if there is -already a record for OPERATION X COMPONENT, DATA will be quietly -discarded instead of recorded. - Starting with 2.006, TRAVERSE will store an integer in data, -so that nodes can be sorted in decreasing order of traversal.")) +This data value will be an ACTION-STATUS object.")) +(defgeneric* mark-component-visited (operation component action-status) + (:documentation "Record ACTION-STATUS as being associated with OPERATION and COMPONENT. +This is a side-effecting function: the association will be recorded on +the ROOT OPERATION (OPERATION-ANCESTOR of the OPERATION).")) (defgeneric* (setf visiting-component) (new-value operation component)) @@ -2253,6 +2243,14 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (latest-stamp-f stamp (funcall fun dep-o dep-c)))) stamp) +(defgeneric needed-in-image-p (operation component) + (:method ((o operation) (c component)) + ;; We presume that actions that modify the filesystem don't need be run + ;; in the current image if they have already been done in another, + ;; and can be run in another process (e.g. a fork), + ;; whereas those that don't are meant to side-effect the current image and can't. + (not (output-files o c)))) + (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes (defun* visit-action (o c plan recurse fun) @@ -2263,7 +2261,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (visit-dependencies o c recurse) (multiple-value-bind (stamp done-p) (compute-action-stamp o c :plan plan) - (funcall fun o c done-p stamp)))) + (funcall fun done-p stamp)))) (defmethod mark-component-visited ((o operation) (c component) data) (unless (nth-value 1 (component-visited-p o c)) @@ -2282,13 +2280,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (declare (ignorable plan)) (nth-value 1 (component-operation-time o c))) -(defmethod action-visited-stamp ((plan (eql 'traverse)) (o operation) (c component)) - (declare (ignorable plan)) - (car (component-visited-p o c))) -(defmethod action-already-done-p ((plan (eql 'traverse)) (o operation) (c component)) - (declare (ignorable plan)) - (second (component-visited-p o c))) - (defmethod mark-operation-done ((o operation) (c component)) (setf (gethash (type-of o) (component-operation-times c)) (compute-action-stamp o c :just-done t))) @@ -2361,27 +2352,83 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (defmacro with-component-being-visited ((o c) &body body) `(call-with-component-being-visited ,o ,c #'(lambda () ,@body))) -(defgeneric* traverse-action (operation component collect)) - -(defmethod traverse-action ((o operation) (c component) collect) - ;; Have we been visited yet? If so, just process the result. - (multiple-value-bind (s p) (component-visited-p o c) - (if p (car s) - (with-component-being-visited (o c) - (funcall 'visit-action - o c 'traverse - #'(lambda (o c) (traverse-action o c collect)) - #'(lambda (o c done-p stamp) - (mark-component-visited o c (cons stamp (unless done-p (incf *visit-count*)))) - (if done-p - (mark-operation-done o c) - (funcall collect (cons o c))) - stamp)))))) +(defclass action-status () + ((stamp + :initarg :stamp :reader action-stamp + :documentation "STAMP associated with the ACTION if it has been completed already +in some previous image, or T if it needs to be done.") + (planned-p + :initarg :planned-p :reader action-planned-p + :documentation "generalized boolean, true iff the action was included in the plan. +If true, an integer indexing the action in the list of actions planned, +or T if already done.")) + (:documentation + "Status of an action in a plan")) + +(defmethod action-visited-stamp ((plan (eql 'traverse)) (o operation) (c component)) + (declare (ignorable plan)) + (aif (component-visited-p o c) (action-stamp it))) + +(defmethod action-already-done-p ((plan (eql 'traverse)) (o operation) (c component)) + (declare (ignorable plan)) + (aif (component-visited-p o c) (action-planned-p it))) + +(defgeneric* traverse-action (operation component needed-in-image-p collect)) + +(defmethod traverse-action ((o operation) (c component) needed-in-image-p collect) + (let ((niip (and needed-in-image-p (needed-in-image-p o c))) + (status (component-visited-p o c))) + (if (and status (or (action-planned-p status) (not niip))) + ;; Already visited with sufficient level of need-in-image: just return the stamp. + (action-stamp status) + (labels ((recurse (niip) + #'(lambda (o c) (traverse-action o c niip collect))) + (revisit-harder () + ;; but it was first visited without + (visit-action + o c 'traverse (recurse t) + #'(lambda (done-p stamp) + (assert (not done-p)) + (mark-component-visited + o c (make-instance 'action-status + :stamp stamp + :planned-p (incf *visit-count*))) + (funcall collect (cons o c)) + stamp)))) + (with-component-being-visited (o c) + (cond + (status + ;; Already visited, it had all its input up-to-date, + ;; wasn't previously need in image but now is. + (revisit-harder)) + (t + ;; Not visited yet. + (visit-action + o c 'traverse (recurse niip) + #'(lambda (done-p stamp) + (let ((add-to-plan-p + (or (eql stamp t) (and niip (not done-p))))) + (cond + ((and add-to-plan-p (not niip)) + (revisit-harder)) + (t + (mark-component-visited + o c (make-instance 'action-status + :stamp stamp + :planned-p + (cond + (done-p + (mark-operation-done o c) + t) + (add-to-plan-p + (funcall collect (cons o c)) + (incf *visit-count*))))) + stamp)))))))))))) (defmethod traverse ((o operation) (c component)) (while-collecting (collect) (let ((*visit-count* 0)) - (traverse-action o c #'collect)))) + (traverse-action o c t #'collect)))) (defmethod perform ((o operation) (c source-file)) (sysdef-error diff --git a/test/test-missing-lisp-file.asd b/test/test-missing-lisp-file.asd index 5c32bb8f..605b4fcf 100644 --- a/test/test-missing-lisp-file.asd +++ b/test/test-missing-lisp-file.asd @@ -1,5 +1,5 @@ ;;; -*- Lisp -*- (asdf:defsystem test-missing-lisp-file - :components ((:file "file2" :in-order-to ((compile-op (load-op "fileMissing")))) + :components ((:file "file2" :in-order-to ((compile-op (load-op "fileMissing")) + (load-op (load-op "fileMissing")))) (:file "fileMissing"))) - diff --git a/test/test-samedir-modules.asd b/test/test-samedir-modules.asd index ae7f049b..274381e4 100644 --- a/test/test-samedir-modules.asd +++ b/test/test-samedir-modules.asd @@ -2,8 +2,8 @@ (asdf:defsystem test-samedir-modules :components ((:module "here" :components - ( - (:file "file2" :in-order-to ((compile-op (load-op "file1")))) + ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) (:file "file1")) :pathname ""))) diff --git a/test/test-samedir-modules.script b/test/test-samedir-modules.script index 07202716..243d5c6d 100644 --- a/test/test-samedir-modules.script +++ b/test/test-samedir-modules.script @@ -4,16 +4,15 @@ (quit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (DBG "loading test-samedir-modules") (asdf:operate 'asdf:load-op 'test-samedir-modules) - ;; test that it compiled (let* ((file1 (asdf:compile-file-pathname* "file1")) (file2 (asdf:compile-file-pathname* "file2")) (file1-date (file-write-date file1))) - (format t "~&test samedir modules 1: ~S ~S~%" file1 file1-date) + (DBG "test that it compiled" file1 file1-date) (assert file1-date) (assert (file-write-date file2)) - ;; and loaded + (DBG "and loaded") (assert (symbol-value (find-symbol (symbol-name :*file1*) :test-package))))) - diff --git a/test/test1.asd b/test/test1.asd index 3acad96e..862f2ad4 100644 --- a/test/test1.asd +++ b/test/test1.asd @@ -1,8 +1,8 @@ ;;; -*- Lisp -*- (asdf:defsystem test1 - :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) (:file "file1"))) - #| 1) from clean, check that all fasl files build and that some function defined in the second file is present diff --git a/test/test1.script b/test/test1.script index 22186edf..5354db53 100644 --- a/test/test1.script +++ b/test/test1.script @@ -4,14 +4,14 @@ (quit-on-error (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (DBG "loading test1") (asdf:load-system 'test1) - ;; test that it compiled (let* ((file1 (asdf:compile-file-pathname* "file1")) (file2 (asdf:compile-file-pathname* "file2")) (file1-date (file-write-date file1)) (file2-date (file-write-date file2))) - (format t "~&test1 1: ~S ~S~%" file1 file1-date) + (DBG "test that it compiled" file1 file1-date) (assert file1-date) (assert file2-date) @@ -22,7 +22,7 @@ (asdf::delete-file-if-exists file2) ;; filesystem mtime has 1 second granularity. Make sure even fast machines see a difference. (sleep 1.5) - (asdf:operate 'asdf:load-op 'test1) + (asdf:load-system 'test1) (assert (= file1-date (file-write-date file1))) (assert (< file2-date (file-write-date file2))) diff --git a/test/test2.asd b/test/test2.asd index bbfe4056..e3c75908 100644 --- a/test/test2.asd +++ b/test/test2.asd @@ -1,6 +1,7 @@ ;;; -*- Lisp -*- (asdf:defsystem test2b :version "1.0" - :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) (:file "file1")) :depends-on (version 'test2a "1.1")) diff --git a/test/test2.script b/test/test2.script index 7480123a..641d43d6 100644 --- a/test/test2.script +++ b/test/test2.script @@ -2,25 +2,25 @@ (load "script-support.lisp") (load-asdf) (quit-on-error - (format t "test2 1~%") (setf asdf:*central-registry* '(*default-pathname-defaults*)) - (asdf:oos 'asdf:load-op 'test2b1) - (format t "test2 2~%") + (DBG "test2: loading test2b1") + (asdf:load-system 'test2b1) + (DBG "test2: file3 and file4 were compiled") (assert (and (probe-file (asdf:compile-file-pathname* (truename "file3.lisp"))) (probe-file (asdf:compile-file-pathname* (truename "file4.lisp"))))) - (format t "test2 3~%") + (DBG "test2: loading test2b2 should fail") #-gcl (handler-case - (asdf:oos 'asdf:load-op 'test2b2) + (asdf:load-system 'test2b2) (asdf:missing-dependency (c) (format t "load failed as expected: - ~%~A~%" c)) (:no-error (c) (declare (ignore c)) (error "should have failed, oops"))) - (format t "test2 4~%") + (DBG "test2: loading test2b3 should fail") #-gcl (handler-case - (asdf:oos 'asdf:load-op 'test2b3) + (asdf:load-system 'test2b3) (asdf:missing-dependency (c) (format t "load failed as expected: - ~%~A~%" c)) (:no-error (c) diff --git a/test/test2a.asd b/test/test2a.asd index c9de77ee..b488e396 100644 --- a/test/test2a.asd +++ b/test/test2a.asd @@ -1,12 +1,9 @@ ;;; -*- Lisp -*- (asdf:defsystem test2a :version "1.1" - :components ((:file "file4" :in-order-to ((compile-op (load-op "file3")))) + :components ((:file "file4" :in-order-to ((compile-op (load-op "file3")) + (load-op (load-op "file3")))) (:file "file3"))) #| this system is referenced by test2b[12] |# - - - - diff --git a/test/test2b1.asd b/test/test2b1.asd index f91f21e3..06987e0c 100644 --- a/test/test2b1.asd +++ b/test/test2b1.asd @@ -1,6 +1,7 @@ ;;; -*- Lisp -*- (asdf:defsystem test2b1 :version "1.0" - :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) (:file "file1")) :in-order-to ((load-op (load-op (:version test2a "1.1"))))) diff --git a/test/test2b2.asd b/test/test2b2.asd index 4c4cfb91..6faa9f5c 100644 --- a/test/test2b2.asd +++ b/test/test2b2.asd @@ -1,7 +1,8 @@ ;;; -*- Lisp -*- (asdf:defsystem test2b2 :version "1.0" - :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) (:file "file1")) :in-order-to ((load-op (load-op (:version test2a "1.2"))))) diff --git a/test/test2b3.asd b/test/test2b3.asd index 3ec8ae6b..26c794a2 100644 --- a/test/test2b3.asd +++ b/test/test2b3.asd @@ -1,6 +1,7 @@ ;;; -*- Lisp -*- (asdf:defsystem test2b3 :version "1.0" - :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")))) + :components ((:file "file2" :in-order-to ((compile-op (load-op "file1")) + (load-op (load-op "file1")))) (:file "file1")) :depends-on (bet-you-cant-find-this)) -- GitLab