From 474353345f5e2901dfe080e6214ccc694dfdfd5c Mon Sep 17 00:00:00 2001 From: Moonchild Date: Sun, 4 Oct 2020 23:26:13 -0700 Subject: [PATCH] basic structure to allow parallel builds --- example/fancy.build | 68 ++++++++++++++++++++++++++++------------- fb.asd | 4 ++- src/dependable.lisp | 13 ++++++-- src/fb-entry.lisp | 45 ++++++--------------------- src/misc.lisp | 44 ++++++++++++++++++++++++++ src/parallel-build.lisp | 50 ++++++++++++++++++++++++++++++ 6 files changed, 164 insertions(+), 60 deletions(-) create mode 100644 src/misc.lisp create mode 100644 src/parallel-build.lisp diff --git a/example/fancy.build b/example/fancy.build index b79853d..fc33e65 100644 --- a/example/fancy.build +++ b/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 'pretty-name) (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 (slot-value b 'output-files) `(,(slot-value b 'target-binary))) + (setf (pretty-name b) (slot-value b 'target-binary)) + (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 'output-files) (list (slot-value b 'obj-file))) - (setf (slot-value b 'pretty-name) (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 (slot-value b 'input-files) `(,(slot-value b 'source-file))) + (setf (slot-value b 'output-files) `(,(slot-value b 'obj-file))) + (setf (pretty-name b) (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*) diff --git a/fb.asd b/fb.asd index 92b49cb..ca8dcb9 100644 --- a/fb.asd +++ b/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" diff --git a/src/dependable.lisp b/src/dependable.lisp index 82605a2..6ad59f7 100644 --- a/src/dependable.lisp +++ b/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 "") - (unique-key :initform nil))) + (pretty-name :initarg :pretty-name :initform "" :accessor pretty-name) + (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)))) diff --git a/src/fb-entry.lisp b/src/fb-entry.lisp index 00789b7..f543cc1 100644 --- a/src/fb-entry.lisp +++ b/src/fb-entry.lisp @@ -1,37 +1,10 @@ (in-package :fancybuild) -(export '(target 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) +(export 'main) (defun main () (unless (probe-file "fancy.build") - (format t "Could not find build description file 'fancy.build'.~%") - (uiop:quit 1)) + (die "Could not find build description file 'fancy.build'.")) (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 ((target (gethash target-name *targets*))) - (if target - (naively-build target) - (format t "No target named '~a'.~%" target-name)))) - (or (uiop:command-line-arguments) '("default"))) + (let ((targets-list (mapcar #'(lambda (name) + (or (gethash name *targets*) (die "No target named '~a'." name))) + (or (uiop:command-line-arguments) '("default"))))) + (parallel-build (if (cdr targets-list) + (make-instance 'buildable :dependencies targets-list) + (car targets-list)))) + ;(naively-build target) + (with-open-file (fp "fancy.buildcache" :direction :output diff --git a/src/misc.lisp b/src/misc.lisp new file mode 100644 index 0000000..beca85c --- /dev/null +++ b/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) + diff --git a/src/parallel-build.lisp b/src/parallel-build.lisp new file mode 100644 index 0000000..91df104 --- /dev/null +++ b/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)))