Moonchild/fancy-build
1
0
Fork 1
Code Issues Pull Requests Releases Activity

basic structure to allow parallel builds

Browse Source
This commit is contained in:
Moonchild 2020-10-04 23:26:13 -07:00
parent ebad4e91e6
commit 474353345f
6 changed files with 164 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
example/fancy.build
View File

@ -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*)

4
fb.asd
View File

@ -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"

13
src/dependable.lisp
View File

@ -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))))

45
src/fb-entry.lisp
View File

@ -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

44
src/misc.lisp Normal file
View File

@ -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)

50
src/parallel-build.lisp Normal file
View File

@ -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)))