Commit 03815785 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Fix compute-action-stamp when stamp is NIL

Stop unnecessarily re-performing initial input-less actions.

Also fix (setf (action-status nil o c) ...),
which therefore seems not to have been previously used.
parent ab899bc4
(in-package :asdf/plan) (in-package :asdf/plan)
;; NB: Whenever compute-action-stamp is changed, this file must be updated
;; to insert the let-and-DBG statements in the current version of the function.
;; So if you find this file not working, it might be out of date.
(uiop:uiop-debug) (uiop:uiop-debug)
(progn (progn
...@@ -13,14 +17,15 @@ ...@@ -13,14 +17,15 @@
;; in the current image, or NIL if it hasn't. ;; in the current image, or NIL if it hasn't.
;; Note that if e.g. LOAD-OP only depends on up-to-date files, but ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but
;; hasn't been done in the current image yet, then it can have a non-T timestamp, ;; hasn't been done in the current image yet, then it can have a non-T timestamp,
;; yet a NIL done-in-image-p flag. ;; yet a NIL done-in-image-p flag: we can predict what timestamp it will have once loaded,
;; i.e. that of the input-files.
(nest (nest
(block ()) (block ())
(let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date) (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date)
(reduce-direct-dependencies (reduce-direct-dependencies
plan o c o c
#'(lambda (o c stamp) #'(lambda (o c stamp)
(if-let (it (plan-action-status plan o c)) (if-let (it (action-status plan o c))
(latest-stamp stamp (action-stamp it)) (latest-stamp stamp (action-stamp it))
t)) t))
nil))) nil)))
...@@ -28,9 +33,9 @@ ...@@ -28,9 +33,9 @@
(when (and (eq dep-stamp t) (not just-done)) (when (and (eq dep-stamp t) (not just-done))
(let ((outdated-deps (let ((outdated-deps
(reduce-direct-dependencies (reduce-direct-dependencies
plan o c o c
#'(lambda (o c deps) #'(lambda (o c deps)
(if (if-let (it (plan-action-status plan o c)) (if (if-let (it (action-status plan o c))
(not (eq t (action-stamp it)))) (not (eq t (action-stamp it))))
deps deps
(cons (cons o c) deps))) (cons (cons o c) deps)))
...@@ -54,34 +59,38 @@ ...@@ -54,34 +59,38 @@
(out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files))
(missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
(earliest-out (stamps-earliest out-stamps))) (earliest-out (stamps-earliest out-stamps)))
(when (and missing-out (not just-done)) (when (and missing-out (not just-done)) (return (values t nil))))
(DBG "compute-action-stamp: missing outputs" (let (;; Time stamps from the files at hand, and whether any is missing
(cons o c) (all-present (not (or missing-in missing-out)))
missing-out) ;; Has any input changed since we last generated the files?
(return (values t nil)))) (up-to-date-p (stamp<= latest-in earliest-out))
(let* (;; There are three kinds of actions: ;; If everything is up to date, the latest of inputs and outputs is our stamp
(out-op (and out-files t)) ; those that create files on the filesystem (done-stamp (stamps-latest (cons latest-in out-stamps))))
;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
;; When was the thing last actually done? (Now, or ask.)
(op-time (or just-done (component-operation-time o c)))
;; Time stamps from the files at hand, and whether any is missing
(all-present (not (or missing-in missing-out)))
;; Has any input changed since we last generated the files?
(up-to-date-p (stamp<= latest-in earliest-out))
;; If everything is up to date, the latest of inputs and outputs is our stamp
(done-stamp (stamps-latest (cons latest-in out-stamps))))
;; Warn if some files are missing: ;; Warn if some files are missing:
;; either our model is wrong or some other process is messing with our files. ;; either our model is wrong or some other process is messing with our files.
(when (and just-done (not all-present)) (when (and just-done (not all-present))
;; Shouldn't that be an error instead?
(warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
(action-description o c) (action-description o c)
missing-in (length missing-in) (and missing-in missing-out) missing-in (length missing-in) (and missing-in missing-out)
missing-out (length missing-out))) missing-out (length missing-out))))
(let ((already-done-p (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) (let (;; There are three kinds of actions:
(matching-stamp-p (and op-time (eql op-time done-stamp)))) (out-op (and out-files t)) ; those that create files on the filesystem
(DBG "compute-action-stamp" ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
))
;; Status of the action as previously performed in the image
(multiple-value-bind (perform-stamp perform-done-p)
(if just-done
(values done-stamp t)
(component-operation-time o c)))
;; Note that we use stamp<= instead of stamp< to play nice with generated files.
;; Any race condition is intrinsic to the limited timestamp resolution.
(let ((already-done-p (and all-present up-to-date-p (operation-done-p o c)
(not (action-forced-p (forcing (or plan *asdf-session*)) o c))))
(matching-stamp-p (and perform-done-p (eql perform-stamp done-stamp))))
(DBG "compute-action-stamp"
(cons o c) (cons o c)
in-files in-files
in-stamps in-stamps
...@@ -91,23 +100,24 @@ ...@@ -91,23 +100,24 @@
latest-in latest-in
earliest-out earliest-out
up-to-date-p up-to-date-p
op-time perform-stamp
perform-done-p
done-stamp done-stamp
;; (eql op-time done-stamp)
all-present all-present
already-done-p already-done-p
just-done just-done
out-op out-op
matching-stamp-p))) matching-stamp-p))
;; Note that we use stamp<= instead of stamp< to play nice with generated files. ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
;; Any race condition is intrinsic to the limited timestamp resolution. ;; Any race condition is intrinsic to the limited timestamp resolution.
(if (or just-done ;; The done-stamp is valid: if we're just done, or (if (or just-done ;; The done-stamp is valid: if we're just done, or
;; if all filesystem effects are up-to-date and there's no invalidating reason. ;; if all filesystem effects are up-to-date and there's no invalidating reason.
(and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) (and all-present up-to-date-p (operation-done-p o c)
(not (action-forced-p (forcing (or plan *asdf-session*)) o c))))
(values done-stamp ;; return the hard-earned timestamp (values done-stamp ;; return the hard-earned timestamp
(or just-done (or just-done
out-op ;; a file-creating op is done when all files are up to date out-op ;; a file-creating op is done when all files are up to date
;; a image-effecting a placeholder op is done when it was actually run, ;; a image-effecting a placeholder op is done when it was actually run,
(and op-time (eql op-time done-stamp)))) ;; with the matching stamp (and perform-done-p (equal perform-stamp done-stamp)))) ;; with the matching stamp
;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
(values t nil))))) (values t nil)))))
...@@ -9,7 +9,6 @@ ...@@ -9,7 +9,6 @@
:asdf/component :asdf/operation :asdf/action :asdf/lisp-action :asdf/component :asdf/operation :asdf/action :asdf/lisp-action
:asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing) :asdf/system :asdf/system-registry :asdf/find-component :asdf/forcing)
(:export (:export
#:component-operation-time
#:plan #:plan-traversal #:sequential-plan #:*plan-class* #:plan #:plan-traversal #:sequential-plan #:*plan-class*
#:action-status #:action-stamp #:action-done-p #:action-index #:action-planned-p #:action-status #:action-stamp #:action-done-p #:action-index #:action-planned-p
#:action-already-done-p #:+action-status-out-of-date+ #:action-already-done-p #:+action-status-out-of-date+
...@@ -92,8 +91,8 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -92,8 +91,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
(defmethod (setf action-status) (new-status (plan null) (o operation) (c component)) (defmethod (setf action-status) (new-status (plan null) (o operation) (c component))
(let ((times (component-operation-times c))) (let ((times (component-operation-times c)))
(if (action-done-p new-status) (if (action-done-p new-status)
(remhash o times) (setf (gethash o times) (action-stamp new-status))
(setf (gethash o times) (action-stamp new-status)))) (remhash o times)))
new-status)) new-status))
...@@ -178,26 +177,31 @@ initialized with SEED." ...@@ -178,26 +177,31 @@ initialized with SEED."
(missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f))
(earliest-out (stamps-earliest out-stamps))) (earliest-out (stamps-earliest out-stamps)))
(when (and missing-out (not just-done)) (return (values t nil)))) (when (and missing-out (not just-done)) (return (values t nil))))
(let* (;; There are three kinds of actions: (let (;; Time stamps from the files at hand, and whether any is missing
(out-op (and out-files t)) ; those that create files on the filesystem (all-present (not (or missing-in missing-out)))
;;(image-op (and in-files (null out-files))) ; those that load stuff into the image ;; Has any input changed since we last generated the files?
;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing (up-to-date-p (stamp<= latest-in earliest-out))
;; When was the thing last actually done? (Now, or ask.) ;; If everything is up to date, the latest of inputs and outputs is our stamp
(op-time (or just-done (component-operation-time o c))) (done-stamp (stamps-latest (cons latest-in out-stamps))))
;; Time stamps from the files at hand, and whether any is missing
(all-present (not (or missing-in missing-out)))
;; Has any input changed since we last generated the files?
(up-to-date-p (stamp<= latest-in earliest-out))
;; If everything is up to date, the latest of inputs and outputs is our stamp
(done-stamp (stamps-latest (cons latest-in out-stamps))))
;; Warn if some files are missing: ;; Warn if some files are missing:
;; either our model is wrong or some other process is messing with our files. ;; either our model is wrong or some other process is messing with our files.
(when (and just-done (not all-present)) (when (and just-done (not all-present))
;; Shouldn't that be an error instead?
(warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~
~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]"
(action-description o c) (action-description o c)
missing-in (length missing-in) (and missing-in missing-out) missing-in (length missing-in) (and missing-in missing-out)
missing-out (length missing-out)))) missing-out (length missing-out))))
(let (;; There are three kinds of actions:
(out-op (and out-files t)) ; those that create files on the filesystem
;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
))
;; Status of the action as previously performed in the image
(multiple-value-bind (perform-stamp perform-done-p)
(if just-done
(values done-stamp t)
(component-operation-time o c)))
;; Note that we use stamp<= instead of stamp< to play nice with generated files. ;; Note that we use stamp<= instead of stamp< to play nice with generated files.
;; Any race condition is intrinsic to the limited timestamp resolution. ;; Any race condition is intrinsic to the limited timestamp resolution.
(if (or just-done ;; The done-stamp is valid: if we're just done, or (if (or just-done ;; The done-stamp is valid: if we're just done, or
...@@ -208,7 +212,7 @@ initialized with SEED." ...@@ -208,7 +212,7 @@ initialized with SEED."
(or just-done (or just-done
out-op ;; a file-creating op is done when all files are up to date out-op ;; a file-creating op is done when all files are up to date
;; a image-effecting a placeholder op is done when it was actually run, ;; a image-effecting a placeholder op is done when it was actually run,
(and op-time (eql op-time done-stamp)))) ;; with the matching stamp (and perform-done-p (equal perform-stamp done-stamp)))) ;; with the matching stamp
;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
(values t nil))))) (values t nil)))))
......
Markdown is supported
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