;;; This is POIU: Parallel Operator on Independent Units
(cl:in-package :asdf)
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defparameter *poiu-version* "1.013")
-(defparameter *asdf-version-required-by-poiu* "1.710"))
+(defparameter *poiu-version* "1.014")
+(defparameter *asdf-version-required-by-poiu* "1.711"))
#|
POIU is a modification of ASDF that may operate on your systems in parallel.
This version of POIU was designed to work with ASDF no earlier than specified.
particular are randomized, it is necessary to record them to replay &
debug them later.")
+(defvar *breadcrumbs* nil
+ "Actual breadcrumbs found, to override traversal for replay and debugging")
+
(defgeneric can-run-in-background-p (operation)
(:method ((operation parallelizable-operation))
nil))
,@(component-module-path c)))
(force-output *breadcrumb-stream*)))
-(defmethod perform ((operation parallelizable-operation) (module module))
+(defmethod perform-with-restarts ((operation parallelizable-operation) (module module))
(multiple-value-bind (ops ind dir) (make-checked-dependency-trees operation module)
(labels ((opspec-op (opspec)
(make-instance (first opspec)))
(opspec-component opened-op)))))
(if (can-run-in-background-p (opspec-op opened-op))
(push opened-op ops)
- (setf ops (nconc ops (list opened-op)))))))
+ (nconcf ops (list opened-op))))))
(when (or (not (operation-done-p (opspec-op op) (opspec-component op)))
(opspec-necessary-p op))
(perform-with-restarts (opspec-op op) (opspec-component op)))))
"Direct dependency table is not empty - there is a problem ~
with the dependency trees:~%~S" (summarize-direct-deps dir)))))
-(defmethod traverse ((operation parallelizable-operation) (c module))
+(defmethod do-traverse ((operation parallelizable-operation) (c module) collect)
(when (component-visiting-p operation c)
(error 'circular-dependency
:components (list c)))
- (setf (visiting-component operation c) t)
- (prog1
- (unless (component-visited-p operation c)
- (nconc
- (loop
- :for (required-op . deps) :in (component-depends-on operation c)
- :for required-deeds =
- (loop
- :for req-c :in deps
- :for dep-c = (or (find-component
- (component-parent c)
- (coerce-name req-c)) ;; TODO: version
- (error 'missing-dependency
- :required-by c
- :requires req-c))
- :for dep-op = (make-sub-operation c operation dep-c required-op)
- :collect (cons dep-op dep-c))
- :append (loop :for (dep-op . dep-c) :in required-deeds
- :append (traverse dep-op dep-c)))
- (list (cons operation c))))
- (setf (visiting-component operation c) nil)
- (visit-component operation c t)))
+ (unless (component-visited-p operation c)
+ (setf (visiting-component operation c) t)
+ (loop
+ :for (required-op . deps) :in (component-depends-on operation c)
+ :for required-deeds =
+ (loop
+ :for req-c :in deps
+ :for dep-c = (or (find-component
+ (component-parent c)
+ (coerce-name req-c)) ;; TODO: version
+ (error 'missing-dependency
+ :required-by c
+ :requires req-c))
+ :for dep-op = (make-sub-operation c operation dep-c required-op) :do
+ (do-traverse dep-op dep-c collect)) :do
+ (do-collect collect (cons operation c)))
+ (setf (visiting-component operation c) nil))
+ (visit-component operation c t))
(defmethod perform :before ((operation parallel-compile-op) (c source-file))
(map nil #'ensure-directories-exist (output-files operation c)))
;;; invoking operations
(defun read-breadcrumbs-from (pathname)
-
(labels ((resolve-component-path (component path)
(if (null path)
component
(resolve-component-path (find-system system-name)
component-path))))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (fmakunbound 'operate)
- (defun call-recording-breadcrumbs (pathname record-p thunk)
- (if record-p
- (with-open-file (*breadcrumb-stream*
- pathname :direction :output
- :if-exists :supersede :if-does-not-exist :create)
- (funcall thunk))
- (funcall thunk)))
- (defmacro recording-breadcrumbs ((pathname record-p) &body body)
- `(call-recording-breadcrumbs ,pathname ,record-p (lambda () ,@body)))
-
- (defun operate (operation-class system &rest args &key (verbose t) version
- (breadcrumbs-to nil record-breadcrumbs-p)
- ((:using-breadcrumbs-from breadcrumb-input-pathname)
- (make-broadcast-stream) read-breadcrumbs-p)
- &allow-other-keys)
- (let* ((op (apply #'make-instance operation-class
- :original-initargs args
- args))
- (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
- (system (if (typep system 'component) system (find-system system))))
- (unless (version-satisfies system version)
- (error 'missing-component :requires system :version version))
- (recording-breadcrumbs (breadcrumbs-to record-breadcrumbs-p)
- (labels ((operation-necessary (op c)
- (not (operation-done-p op c))))
- (let ((steps (if read-breadcrumbs-p
- (read-breadcrumbs-from breadcrumb-input-pathname)
- (traverse op system))))
- (with-compilation-unit ()
- (loop :for (op . component) :in steps :do
- (loop
- (restart-case
- (progn (when (operation-necessary op component)
- (perform-with-restarts 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))))))))))))
+(defun call-recording-breadcrumbs (pathname record-p thunk)
+ (if record-p
+ (with-open-file (*breadcrumb-stream*
+ pathname :direction :output
+ :if-exists :supersede :if-does-not-exist :create)
+ (funcall thunk))
+ (funcall thunk)))
+(defmacro recording-breadcrumbs ((pathname record-p) &body body)
+ `(call-recording-breadcrumbs ,pathname ,record-p (lambda () ,@body)))
+
+(defmethod traverse :around ((operation-class parallelizable-operation) system)
+ (or *breadcrumbs* (call-next-method)))
+
+(defmethod operate :around ((operation-class parallelizable-operation) system &key
+ (breadcrumbs-to nil record-breadcrumbs-p)
+ ((:using-breadcrumbs-from breadcrumb-input-pathname)
+ (make-broadcast-stream) read-breadcrumbs-p)
+ &allow-other-keys)
+ (recording-breadcrumbs (breadcrumbs-to record-breadcrumbs-p)
+ (let ((*breadcrumbs* (when read-breadcrumbs-p
+ (read-breadcrumbs-from breadcrumb-input-pathname))))
+ (call-next-method))))
+
+(defmethod perform-with-restart :around ((operation parallelizable-operation) c)
+ (unless (operation-done-p operation c)
+ (call-next-method)))
(in-package :cl-user)
(require :asdf)
-(unless (or #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "1.705"))
+(unless (or #+asdf2 (asdf:version-satisfies (asdf:asdf-version) "1.711"))
(push "/home/fare/cl/asdf/" asdf:*central-registry*)
(asdf:oos 'asdf:load-op :asdf))
+(in-package :asdf)
+
(setf *load-verbose* t
*load-print* t
*compile-verbose* t
*compile-print* t)
-(push "/home/fare/.local/share/common-lisp/systems/" asdf:*central-registry*)
+(defmacro dbg (tag &rest exprs)
+ "simple debug statement macro:
+outputs a tag plus a list of source expressions and their resulting values, returns the last values"
+ (let ((res (gensym))(f (gensym)))
+ `(let ((,res))
+ (flet ((,f (fmt &rest args) (apply #'format *trace-output* fmt args)))
+ (,f "~&~A~%" ,tag)
+ ,@(mapcan
+ #'(lambda (x)
+ `((,f "~& ~S => " ',x)
+ (,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x)))))
+ exprs)
+ (apply 'values ,res)))))
+
(asdf:oos 'asdf:load-op :poiu :verbose t)
(asdf:oos 'asdf:load-op :cl-launch :verbose t)
*compile-verbose* t
*compile-print* t)
+(format *error-output* "~&POIU ~A~%" asdf::*poiu-version*)
+
+(trace asdf:operate asdf::traverse asdf::make-checked-dependency-trees
+ ;;asdf::can-run-in-background-p asdf::call-queue/forking ;; asdf::operation-executed-p
+ ;; asdf:perform
+ ;;asdf::operation-done-p
+ asdf::perform-with-restarts)
+
+#|
+(defmethod operation-done-p ((o operation) (c component))
+ (let ((out-files (output-files o c))
+ (in-files (input-files o c))
+ (op-time (gethash (type-of o) (component-operation-times c))))
+ (DBG :odp o c out-files in-files op-time)
+ (flet ((earliest-out ()
+ (reduce #'min (mapcar #'safe-file-write-date out-files)))
+ (latest-in ()
+ (reduce #'max (mapcar #'safe-file-write-date in-files))))
+ (cond
+ ((and (not in-files) (not out-files))
+ ;; arbitrary decision: an operation that uses nothing to
+ ;; produce nothing probably isn't doing much.
+ ;; e.g. operations on systems, modules that have no immediate action,
+ ;; but are only meaningful through traversed dependencies
+ t)
+ ((not out-files)
+ ;; an operation without output-files is probably meant
+ ;; for its side-effects in the current image,
+ ;; assumed to be idem-potent,
+ ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
+ (and op-time (>= op-time (latest-in))))
+ ((not in-files)
+ ;; an operation without output-files and no input-files
+ ;; is probably meant for its side-effects on the file-system,
+ ;; assumed to have to be done everytime.
+ ;; (I don't think there is any such case in ASDF unless extended)
+ nil)
+ (t
+ ;; an operation with both input and output files is assumed
+ ;; as computing the latter from the former,
+ ;; assumed to have been done if the latter are all older
+ ;; than the former.
+ ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
+ ;; We use >= instead of > to play nice with generated files.
+ ;; This opens a race condition if an input file is changed
+ ;; after the output is created but within the same second
+ ;; of filesystem time; but the same race condition exists
+ ;; whenever the computation from input to output takes more
+ ;; than one second of filesystem time (or just crosses the
+ ;; second). So that's cool.
+ (DBG :odp2 (mapcar 'probe-file in-files) (mapcar 'probe-file out-files)
+ (earliest-out) (latest-in)
+ (and
+ (every #'probe-file in-files)
+ (every #'probe-file out-files)
+ (>= (earliest-out) (latest-in))))))))
+)|#
+
(asdf:oos 'asdf:parallel-load-op :exscribe :verbose t)
+
(exscribe::process-command-line
'("-I" "/home/fare/fare/www" "-o" "-" "-H" "/home/fare/fare/www/index.scr"))
common-lisp.net / projects/qitab/poiu.git / commitdiff
