basic structure to allow parallel builds

example/fancy.build

@@ -1,6 +1,31 @@
 (defun runp (cmd)
   (assert (zerop (uiop:wait-process (uiop:launch-program cmd :output *standard-output* :error-output *error-output*)))))
 
+(defclass c-compiler (buildable)
+  ((cached-snapshot :accessor c-compiler-executable :initform nil)
+   (supports-md :initform nil)))
+(defmethod initialize-instance :after ((b c-compiler) &key)
+  (setf (unique-key b) 'cc))
+(defmethod do-build ((b c-compiler))
+  ; todo more sophisticated c compiler location mechanics
+  (runp "cc -v")
+  (setf (c-compiler-executable b) "cc -c")
+  (setf (slot-value b 'supports-md) t))
+(defmethod snapshot ((b c-compiler)) (c-compiler-executable b))
+(defmethod is-dirty ((b c-compiler) old) (not (string-equal (c-compiler-executable b) old)))
+
+; will this ever be different from the compiler?
+(defclass c-linker (buildable)
+  ((cached-snapshot :accessor c-linker-executable :initform nil)))
+(defmethod initialize-instance :after ((b c-linker) &key)
+  (setf (unique-key b) 'ccld))
+(defmethod do-build ((b c-linker))
+  ; todo: ditto more sophisticated
+  (runp "cc -v")
+  (setf (c-linker-executable b) "cc"))
+(defmethod snapshot ((b c-linker)) (c-linker-executable b))
+(defmethod is-dirty ((b c-linker) old) (not (string-equal (c-linker-executable b) old)))
+
 (defclass c-source-buildable (rebuilt-on-file-change)
   ((source-file :initarg :source-file)
    (obj-file :initarg :obj-file)))
@@ -10,24 +35,36 @@
    (obj-files)))
 
 (defmethod initialize-instance :after ((b c-binary-buildable) &key)
-  (setf (slot-value b 'obj-files) (mapcar #'(lambda (x) (slot-value x 'obj-file)) (remove-if-not #'(lambda (x) (typep x 'c-source-buildable)) (slot-value b 'dependencies))))
+  (setf (slot-value b 'obj-files)
+	(mapcar #'(lambda (x)
+		    (slot-value x 'obj-file))
+		(remove-if-not #'(lambda (x) (typep x 'c-source-buildable))
+			       (dependencies b))))
   (setf (slot-value b 'input-files) (slot-value b 'obj-files))
-  (setf (slot-value b 'output-files) (list (slot-value b 'target-binary)))
+  (setf (slot-value b 'output-files) `(,(slot-value b 'target-binary)))
-  (setf (slot-value b 'pretty-name) (slot-value b 'target-binary))
+  (setf (pretty-name b) (slot-value b 'target-binary))
-  (setf (slot-value b 'unique-key) (cons 'c-binary-buildable (cons (slot-value b 'target-binary) (slot-value b 'obj-files)))))
+  (setf (unique-key b) (cons 'c-binary-buildable (cons (slot-value b 'target-binary) (slot-value b 'obj-files))))
+  (push (make-instance 'c-linker) (dependencies b)))
 
 (defmethod do-build ((b c-binary-buildable))
-  (runp (format nil "cc -o ~a ~{~a~^ ~}" (slot-value b 'target-binary) (slot-value b 'obj-files))))
+  (runp (format nil "~a -o ~a ~{~a~^ ~}"
+		(c-linker-executable (car (dependencies b)))
+		(slot-value b 'target-binary)
+		(slot-value b 'obj-files))))
 
 (defmethod initialize-instance :after ((b c-source-buildable) &key)
-  (setf (slot-value b 'input-files) (list (slot-value b 'source-file)))
+  (setf (slot-value b 'input-files) `(,(slot-value b 'source-file)))
-  (setf (slot-value b 'output-files) (list (slot-value b 'obj-file)))
+  (setf (slot-value b 'output-files) `(,(slot-value b 'obj-file)))
-  (setf (slot-value b 'pretty-name) (slot-value b 'source-file))
+  (setf (pretty-name b) (slot-value b 'source-file))
-  (setf (slot-value b 'unique-key) (list 'c-source-buildable (slot-value b 'obj-file) (slot-value b 'source-file))))
+  (setf (unique-key b) `(c-source-buildable ,(slot-value b 'obj-file) ,(slot-value b 'source-file)))
+  (push (make-instance 'c-compiler) (dependencies b)))
 
 (defmethod do-build ((b c-source-buildable))
   (ensure-directories-exist (directory-namestring (slot-value b 'obj-file)))
-  (runp (format nil "cc -c -o ~a ~a" (slot-value b 'obj-file) (slot-value b 'source-file))))
+  (runp (format nil "~a -o ~a ~a"
+		(c-compiler-executable (car (dependencies b)))
+		(slot-value b 'obj-file)
+		(slot-value b 'source-file))))
 
 (defun c-source (file)
   (make-instance 'c-source-buildable
@@ -35,7 +72,6 @@
                  :obj-file (format nil "build/~a.o" file)))
 (defun c-sourcelist (srclist)
   (mapcar #'c-source srclist))
-;(c-sourcelist srclist)
 
 (defun c-binary (bin deps)
   (make-instance 'c-binary-buildable
@@ -49,15 +85,5 @@
   (c-binary "test2"
             (c-sourcelist '("src/add.c" "src/test2.c"))))
 
-;(defparameter x (make-instance 'c-source-buildable
-;                               :source-file "test/test.c"
-;                               :obj-file "build/test/test.o"))
-;(defparameter y (make-instance 'c-source-buildable
-;                               :source-file "test/add.c"
-;                               :obj-file "build/test/add.o"))
-;(defparameter z (make-instance 'c-binary-buildable
-;                               :target-binary "build/test/test"
-;                               :dependencies (list x y)))
-
 (target "default" *t1*)
 (target "other" *t2*)

fb.asd

@@ -9,8 +9,10 @@
     :depends-on (#:osicat #:ironclad #:cl-conspack)
 
     :components ((:file "dependable")
+		 (:file "misc" :depends-on ("dependable"))
+		 (:file "parallel-build" :depends-on ("dependable" "misc"))
 		 (:file "buildables/rebuilt-on-file-change" :depends-on ("dependable"))
-		 (:file "fb-entry" :depends-on ("dependable")))
+		 (:file "fb-entry" :depends-on ("dependable" "parallel-build" "misc")))
 		 ;(:file "x" :depends-on ("y" "z"))
 
     :build-pathname "fb"

src/dependable.lisp

@@ -9,12 +9,19 @@
 (in-package :fancybuild)
 
 (defclass buildable ()
-  ((dependencies :initarg :dependencies :initform nil)
+  ((dependencies :initarg :dependencies :initform nil :accessor dependencies)
    (cached-snapshot :initform nil)
-   (pretty-name :initarg :pretty-name :initform "")
+   (pretty-name :initarg :pretty-name :initform "" :accessor pretty-name)
-   (unique-key :initform nil)))
+   (unique-key :initform nil :accessor unique-key)))
 
 (defgeneric snapshot (buildable))
 (defgeneric is-dirty (buildable old))
 (defgeneric do-build (buildable))
 
+(defmethod snapshot ((b buildable)))
+(defmethod is-dirty ((b buildable) o) t)
+(defmethod do-build ((b buildable)))
+
+(defun check-dirty (b)
+  (or (null (slot-value b 'cached-snapshot))
+      (is-dirty b (slot-value b 'cached-snapshot))))

src/fb-entry.lisp

@@ -1,37 +1,10 @@
 (in-package :fancybuild)
 
-(export '(target main))
+(export 'main)
-
-(defparameter *targets* (make-hash-table :test #'equal))
-(defparameter *global-cache* (make-hash-table :test #'equal))
-
-(defun target (name target)
-  (setf (gethash name *targets*) target))
-
-(defun naively-build (b)
-  (mapcar #'naively-build (slot-value b 'dependencies))
-  (when (and (not (slot-value b 'cached-snapshot))
-             (slot-value b 'unique-key)
-             (gethash (slot-value b 'unique-key) *global-cache*))
-    (setf (slot-value b 'cached-snapshot) (gethash (slot-value b 'unique-key) *global-cache*)))
-
-  (unless (and (slot-value b 'cached-snapshot)
-               (not (is-dirty b (slot-value b 'cached-snapshot))))
-    (format t "Building ~a...~%" (slot-value b 'pretty-name))
-    (handler-case (do-build b)
-      (error ()
-             (format t "Error building ~a!~%" (slot-value b 'pretty-name))
-             (uiop:quit 1))))
-  (setf (slot-value b 'cached-snapshot) (snapshot b))
-  (when (slot-value b 'unique-key)
-    (setf (gethash (slot-value b 'unique-key) *global-cache*)
-          (slot-value b 'cached-snapshot)))
-  nil)
 
 (defun main ()
   (unless (probe-file "fancy.build")
-    (format t "Could not find build description file 'fancy.build'.~%")
+    (die "Could not find build description file 'fancy.build'."))
-    (uiop:quit 1))
 
   (when (probe-file "fancy.buildcache")
     (with-open-file (fp "fancy.buildcache"
@@ -47,12 +20,14 @@
     (in-package :fancily-built)
     (load "fancy.build"))
 
-  (mapcar #'(lambda (target-name)
+  (let ((targets-list (mapcar #'(lambda (name)
-              (let ((target (gethash target-name *targets*)))
+                                  (or (gethash name *targets*) (die "No target named '~a'." name)))
-                (if target
+                              (or (uiop:command-line-arguments) '("default")))))
-                  (naively-build target)
+    (parallel-build (if (cdr targets-list)
-                  (format t "No target named '~a'.~%" target-name))))
+                      (make-instance 'buildable :dependencies targets-list)
-          (or (uiop:command-line-arguments) '("default")))
+                      (car targets-list))))
+                  ;(naively-build target)
+
 
   (with-open-file (fp "fancy.buildcache"
                       :direction :output

src/misc.lisp

@@ -0,0 +1,44 @@
+(in-package :fancybuild)
+
+(export 'target)
+
+(defparameter *targets* (make-hash-table :test #'equal))
+(defparameter *global-cache* (make-hash-table :test #'equal))
+
+(defmacro aif (test then &optional else)
+  `(let ((- ,test))
+     (if - ,then ,else)))
+(defmacro awhen (test &body body)
+  `(let ((- ,test))
+     (when - ,@body)))
+(defmacro aunless (test &body body)
+  `(let ((- ,test))
+     (unless - ,@body)))
+
+(defun die (&rest msg)
+  (apply #'format (cons t msg))
+  (format t "~%")
+  (uiop:quit 1))
+
+(defun target (name target)
+  (setf (gethash name *targets*) target))
+
+(defun naively-build (b)
+  (mapcar #'naively-build (dependencies b))
+  (when (and (not (slot-value b 'cached-snapshot))
+             (unique-key b)
+             (gethash (unique-key b) *global-cache*))
+    (setf (slot-value b 'cached-snapshot) (gethash (unique-key b) *global-cache*)))
+
+  (unless (and (slot-value b 'cached-snapshot)
+               (not (is-dirty b (slot-value b 'cached-snapshot))))
+    (format t "Building ~a...~%" (pretty-name b))
+    (handler-case (do-build b)
+      (error ()
+             (die "Error building ~a!" (pretty-name b)))))
+  (setf (slot-value b 'cached-snapshot) (snapshot b))
+  (when (unique-key b)
+    (setf (gethash (unique-key b) *global-cache*)
+          (slot-value b 'cached-snapshot)))
+  nil)
+

src/parallel-build.lisp

@@ -0,0 +1,50 @@
+(in-package :fancybuild)
+
+(defstruct parallel-buildable
+  (base)
+  (refcount 0)
+  (dependents nil))
+
+(defun construct-build-graph (b table)
+  (let ((ret (if (gethash (unique-key b) table)
+               (gethash (unique-key b) table)
+               ; buildables are allowed to have nil keys, but replace with a dummy in that case
+               ; because we need the value to be in the table
+               (let ((key (or (unique-key b) (gensym))))
+                 (setf (slot-value b 'cached-snapshot) (gethash key *global-cache*))
+                 (setf (gethash key table) (make-parallel-buildable :base b))))))
+
+    ; update dependencies, because construct-build-graph might run a deduplication on a dependency
+    ; that being the case, if 'b' looks at one of its dependencies, it would see a stale dep--no bueno
+    ; (this happens in practice with c-compiler and c-linker, which are depended on by 'most everything, but heavily dedup'd)
+    ; so give it the new version
+    (setf (dependencies b)
+          (loop :for x :in (dependencies b)
+                :collect (progn (incf (parallel-buildable-refcount ret))
+                                (let ((newx (construct-build-graph x table)))
+                                  (push ret (parallel-buildable-dependents newx))
+                                  (parallel-buildable-base newx)))))
+    ret))
+
+(defun execute-parallel-build (table)
+  (let ((currently-buildable '()))
+    (flet ((unref (b)
+                  (assert (> (parallel-buildable-refcount b) 0))
+                  (when (= 0 (decf (parallel-buildable-refcount b)))
+                    (push b currently-buildable))))
+      (loop for v being the hash-value of table
+            do (when (= (parallel-buildable-refcount v) 0) (push v currently-buildable)))
+      (loop :while currently-buildable
+            :do (let ((b (pop currently-buildable)))
+                  (when (check-dirty (parallel-buildable-base b))
+                    (awhen (pretty-name (parallel-buildable-base b))
+                           (format t "Building ~a...~%" -))
+                    (do-build (parallel-buildable-base b))
+                    (setf (slot-value (parallel-buildable-base b) 'cached-snapshot) (snapshot (parallel-buildable-base b)))
+                    (setf (gethash (unique-key (parallel-buildable-base b)) *global-cache*) (slot-value (parallel-buildable-base b) 'cached-snapshot)))
+                  (mapcar #'unref (parallel-buildable-dependents b)))))))
+
+(defun parallel-build (buildable)
+  (let ((table (make-hash-table :test #'equal)))
+    (construct-build-graph buildable table)
+    (execute-parallel-build table)))