;;; ;;;
;;; Free Software, same MIT-style license as ASDF. See poiu.lisp. ;;;
;;; ;;;
-;;; Copyright (c) 2001-2010 ITA Software, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2001-2011 ITA Software, Inc. All rights reserved. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(asdf:defsystem :poiu
+(in-package :asdf)
+#-asdf2 (error "XCVB requires ASDF 2")
+
+(let ((old-ver (asdf-version)))
+ (load-system :asdf)
+ (let ((min "2.017.12")
+ (ver (asdf-version)))
+ (unless (or (version-satisfies old-ver "2.014.8") ; first version to do magic upgrade
+ (equal ver old-ver))
+ (error "You must upgrade ASDF to your latest *before* you load POIU~%~
+ If you're trying to load POIU at a REPL, try again, it should work."))
+ (unless (and ver (version-satisfies ver min))
+ (error "POIU requires ASDF ~D or later, you only have ~D" min ver))))
+
+(defsystem :poiu
:author ("Daniel Barlow" "Andreas Fuchs" "Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau"
:licence "MIT"
POIU will notably compile each Lisp file in its own forked process,
in parallel with other operations (compilation or loading).
However, it will load FASLs serially as they become available."
- ;; It is not currently safe to upgrade asdf itself as part of an asdf operation;
- ;; that would require special magic handling by asdf. So we don't try.
- ;; :depends-on ((:version :asdf "2.010"))
+ :depends-on ((:version :asdf "2.017.12"))
:components ((:file "poiu")))
;;; This is POIU: Parallel Operator on Independent Units
(cl:in-package :asdf)
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defparameter *poiu-version* "1.019")
-(defparameter *asdf-version-required-by-poiu* "2.010"))
+(defparameter *poiu-version* "1.020")
+(defparameter *asdf-version-required-by-poiu* "2.017.12"))
#|
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.
To use POIU, (1) make sure asdf.lisp is loaded.
We require a recent enough ASDF 1.705; see specific requirement above.
Usually, you can
- (require :asdf)
+ (require "asdf")
(2) configure ASDF's SOURCE-REGISTRY or its *CENTRAL-REGISTRY*, then load POIU.
- (require :poiu)
+ (require "poiu")
might work on SBCL and CCL. On CLISP, you can definitely
(asdf:load-system :poiu)
(alternatively, you might manually (load "/path/to/poiu"),
(:method ((operation parallelizable-operation))
nil))
+(defgeneric run-in-background-p (operation component &key force))
+
+(defmethod run-in-background-p ((operation parallelizable-operation) component &key force)
+ (and (can-run-in-background-p operation)
+ (or (not (operation-executed-p operation component))
+ force)))
+
(defgeneric dependee-operations-necessary-p (operation component)
(:method ((op compile-op) component)
(declare (ignorable op component))
(make-dependency-trees operation module))
(defparameter *max-forks* 16)
+(defparameter *max-actual-forks* 0)
;;; subprocesses: data structure, ipc
(cond
((funcall background-p elem)
(incf count)
+ (when (> count *max-actual-forks*)
+ (setf *max-actual-forks* count))
(push (make-communicating-subprocess elem thunk cleanup) pid-map))
(t
(unwind-protect (funcall thunk elem)
(cond
((funcall background-p elem)
(incf count)
+ (when (> count *max-actual-forks*)
+ (setf *max-actual-forks* count))
(push (make-communicating-thread pending elem thunk cleanup) processes))
(t
(unwind-protect (funcall thunk elem)
,background-p)))
(defmethod perform :after ((operation parallel-compile-op) c)
- (setf (gethash 'compile-op (component-operation-times c))
- (get-universal-time)))
+ (mark-operation-done (make-instance 'compile-op) c))
(defmethod perform :after ((operation parallel-load-op) c)
- (setf (gethash 'load-op (component-operation-times c))
- (get-universal-time)))
+ (mark-operation-done (make-instance 'load-op) c))
(defmethod perform :after ((operation operation) c)
"Record the operations and components in a stream of breadcrumbs."
(unless (null ops)
(dolist/forking
((op ops :result result)
- :background-p (and (can-run-in-background-p (opspec-op op))
- (or (not (operation-executed-p
- (opspec-op op)
- (opspec-component op)))
- (opspec-necessary-p op)))
+ :background-p (run-in-background-p
+ (opspec-op op) (opspec-component op)
+ :force (opspec-necessary-p op))
:cleanup
(destructuring-bind (&key failure-p performed-p &allow-other-keys)
result
"Direct dependency table is not empty - there is a problem ~
with the dependency trees:~%~S" (summarize-direct-deps dir)))))
-(defmethod do-traverse ((operation parallelizable-operation) (c module) collect)
- (when (component-visiting-p operation c)
- (error 'circular-dependency
- :components (list c)))
- (unless (component-visited-p operation c)
- (setf (visiting-component operation c) t)
- (loop
- :for (required-op . deps) :in (component-depends-on operation c) :do
- (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-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)))
+ (ensure-all-directories-exist (asdf:output-files operation c)))
(defmethod perform ((op parallel-compile-op) (c cl-source-file))
(let ((compile-status (list
(unless output-truename
(error 'compile-error :component c :operation op)))))))
+(defmethod perform-with-restart :around ((operation parallelizable-operation) c)
+ (unless (operation-executed-p operation c)
+ (call-next-method)))
+
(defmethod operation-executed-p ((op parallelizable-operation) (c module))
"A lazy operation on a module is done only when the op on all its
components is done."
`(call-recording-breadcrumbs ,pathname ,record-p (lambda () ,@body)))
(defmethod traverse :around ((operation parallelizable-operation) system)
- (or *breadcrumbs*
- (call-next-method))) ;;; nope: (list (cons operation system))))
+ (append *breadcrumbs*
+ (remove 'system (call-next-method) :test-not #'eq
+ :key (lambda (x) (type-of (cdr x))))))
(defmethod operate :around ((operation-class parallelizable-operation) system &key
(breadcrumbs-to nil record-breadcrumbs-p)
*compile-verbose* t
*compile-print* t)
-(require :asdf)
-(asdf:load-system :asdf) ;; reload always, so we have the latest;
-;; otherwise, poiu will pull the latest, anyway, and that will cause package trouble
-;; if it's different from the current.
+(require "asdf")
(setf *load-verbose* t
*load-print* t
(format *error-output* "~&POIU ~A~%" *poiu-version*)
-;(trace operate traverse make-checked-dependency-trees
- ;;can-run-in-background-p call-queue/forking
- ;;perform
- ;;operation-done-p operation-executed-p
-; perform-with-restarts)
+(defun print-backtrace (out)
+ "Print a backtrace (implementation-defined)"
+ (declare (ignorable out))
+ #+clozure (let ((*debug-io* out))
+ (ccl:print-call-history :count 100 :start-frame-number 1)
+ (finish-output out))
+ #+sbcl
+ (sb-debug:backtrace most-positive-fixnum out))
+
+(trace operate traverse make-checked-dependency-trees
+ run-in-background-p
+ can-run-in-background-p operation-executed-p operation-done-p
+ input-files output-files file-write-date
+ component-operation-time mark-operation-done
+ call-queue/forking make-communicating-subprocess
+ perform perform-with-restarts perform-plan compile-file
+ )
;#+clisp (trace posix-wexitstatus posix-wait)
-(asdf:parallel-load-system :exscribe :verbose t)
+(defmethod operation-done-p ((o operation) (c component))
+ (let ((out-files (output-files o c))
+ (in-files (input-files o c))
+ (op-time (component-operation-time o c)))
+ (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 with 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.
+ (let ((earliest-out (earliest-out))
+ (latest-in (latest-in)))
+ (DBG :odp earliest-out latest-in
+ (and earliest-out latest-in (>= earliest-out latest-in)))
+ (and
+ (every #'probe-file* in-files)
+ (every #'probe-file* out-files)
+ (>= earliest-out latest-in))))))))
+
+(block nil
+ (handler-bind ((error #'(lambda (condition)
+ (format t "~&ERROR:~%~A~%" condition)
+ (print-backtrace *standard-output*)
+ (format t "~&ERROR:~%~A~%" condition)
+ (finish-output)
+ (return))))
+ (asdf:parallel-load-system :exscribe :verbose t)
+ (funcall (find-symbol "PROCESS-COMMAND-LINE" "EXSCRIBE")
+ '("-I" "/home/fare/fare/www" "-o" "-" "-H" "/home/fare/fare/www/index.scr"))))
-(exscribe::process-command-line
- '("-I" "/home/fare/fare/www" "-o" "-" "-H" "/home/fare/fare/www/index.scr"))
+(format t "~&~S~%" (asdf::implementation-identifier))
+(format t "~&Compiled with as many as ~D forked subprocesses~%" *max-actual-forks*)
(cl-launch:quit 0)
common-lisp.net / projects/qitab/poiu.git / commitdiff
