diff --git a/poiu.lisp b/poiu.lisp index 4c53feaf69a02943b330d3c3c5345e02653a2747..9310763f1ebf4b40b1bac41f78bdbfea80028552 100644 --- a/poiu.lisp +++ b/poiu.lisp @@ -1,8 +1,8 @@ ;;; 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. @@ -118,6 +118,9 @@ As the order of ASDF operations in general and parallel operations in 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)) @@ -665,7 +668,7 @@ debug them later.") ,@(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))) @@ -703,7 +706,7 @@ debug them later.") (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))))) @@ -712,32 +715,28 @@ debug them later.") "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))) @@ -807,7 +806,6 @@ components is done." ;;; invoking operations (defun read-breadcrumbs-from (pathname) - (labels ((resolve-component-path (component path) (if (null path) component @@ -820,57 +818,29 @@ components is done." (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 "~@" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@" - 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))) diff --git a/test.lisp b/test.lisp index 49a63a7d34102832d17ecf523584f22ee1ad9f5f..245290cf7a0856ff11b7b4268b1f11d057733a07 100644 --- a/test.lisp +++ b/test.lisp @@ -4,16 +4,31 @@ (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) @@ -22,7 +37,66 @@ *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"))