├── .gitattributes ├── .gitignore ├── LICENSE.txt ├── README.md ├── all.lisp ├── asdf.lisp ├── base.lisp ├── build-env.lisp ├── cache.lisp ├── db.lisp ├── digest.lisp ├── freeze.lisp ├── global-state.lisp ├── kernel.lisp ├── makespan.lisp ├── message.lisp ├── net.lisp ├── oracle.lisp ├── overlord.asd ├── project-system.lisp ├── redo.lisp ├── safer-read.lisp ├── specials.lisp ├── stamp.lisp ├── target-protocol.lisp ├── target-table.lisp ├── target.lisp ├── template ├── application.lisp ├── package.lisp └── system.asd ├── tests.lisp ├── tests ├── literal.txt └── touch-test ├── types.lisp ├── util.lisp └── version.sexp /.gitattributes: -------------------------------------------------------------------------------- 1 | # CRLF breaks the tilde-newline format directive. 2 | *.lisp text eol=lf 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | .overlord 3 | README.html 4 | *~ 5 | tests/tmp 6 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Paul M. Rodriguez 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Overlord 2 | 3 | ## Introduction 4 | 5 | Overlord is a build system in Common Lisp. It is a real build system, 6 | with all the modern features: rules with multiple outputs, parallel 7 | builds, immunity to clock issues, and dynamic dependencies. 8 | 9 | But Overlord is more than another build system. Overlord is a uniform 10 | approach to dependencies inside or outside of a Lisp image. 11 | Conceptually, Overlord is to Make what Lisp macros are to C macros. 12 | 13 | Overlord uses a persistent store to track dependencies. This small 14 | overhead translates into drastically simplified semantics for the 15 | programmer. Much like garbage collection allows programmers largely 16 | not to have to think about lifetimes, persistent dependencies allow 17 | programmers largely not to have to think about phasing. 18 | 19 | For more discussion, [consult the wiki][wiki]. If you are a Lisper, you 20 | might want to jump straight to the [intro for Lispers][intro]. 21 | 22 | ## Advice for users 23 | 24 | Note that, to run the test suite, you will need to 25 | download [Core Lisp][], and, if not on Windows, you must have the 26 | `touch` program in your search path. (On Windows, Powershell is 27 | used instead). 28 | 29 | Overlord stores its persistent data structures in a cache directory. 30 | On Linux, this is `$XDG_CACHE_HOME/overlord`. The data structures 31 | stored there are versioned. It might worth checking the cache 32 | directory from time to time to delete obsolete files. 33 | 34 | Overlord is developed and tested on Clozure and SBCL. In the future it 35 | may officially support other Lisp implementations, but that is not a 36 | priority. 37 | 38 | ## Examples 39 | 40 | Here are some projects that make direct use of Overlord: 41 | 42 | 1. [cl-https-everywhere][]. In-process [HTTPS Everywhere][] rulesets, 43 | automatically fetched from the HTTPS Everywhere repository and 44 | compiled into Lisp code. 45 | 46 | 2. [Proctor][]. Proctor treats tests as build targets, allowing you to 47 | precisely specify their dependencies and re-run tests only when 48 | necessary. 49 | 50 | 3. [Vernacular][]. Provides a module system for embedding languages, 51 | with arbitrary syntaxes, into Common Lisp systems. 52 | 53 | 55 | 56 | [Lisp1.5]: http://www.softwarepreservation.org/projects/LISP/lisp15_family#Lisp_15_Programmers_Manual_ 57 | [phase separation]: http://www.phyast.pitt.edu/~micheles/scheme/scheme21.html 58 | [language tower]: www.phyast.pitt.edu/~micheles/scheme/scheme22.html 59 | [ASDF]: https://common-lisp.net/project/asdf/ 60 | [Racket]: https://racket-lang.org/ 61 | [Redo]: https://github.com/apenwarr/redo 62 | [implicit phasing]: http://www.cs.indiana.edu/~dyb/pubs/implicit-phasing.pdf 63 | [burgled-batteries]: https://github.com/pinterface/burgled-batteries 64 | [Bosom Serpent]: http://github.com/ruricolist/bosom-serpent 65 | [yesql]: https://github.com/krisajenkins/yesql 66 | [cl-yesql]: http://github.com/ruricolist/cl-yesql 67 | [HTTPS Everywhere]: https://github.com/EFForg/https-everywhere 68 | [cl-https-everywhere]: http://github.com/ruricolist/cl-https-everywhere 69 | [Instaparse]: https://github.com/Engelberg/instaparse 70 | [Pseudoscheme]: https://github.com/sharplispers/pseudoscheme 71 | [ragg]: http://www.hashcollision.org/ragg/ 72 | [shlex]: https://github.com/python/cpython/blob/master/Lib/shlex.py 73 | [HCL]: http://www.jucs.org/jucs_16_2/embedding_hygiene_compatible_macros 74 | [Shen]: http://www.shenlanguage.org/ 75 | [Serapeum]: https://github.com/ruricolist/serapeum 76 | [at-exp]: https://docs.racket-lang.org/scribble/reader-internals.html 77 | [CL-JavaScript]: http://marijnhaverbeke.nl/cl-javascript/ 78 | [Snowball]: http://snowballstem.org 79 | [explicit renaming]: https://doi.org/10.1145/1317265.1317269 80 | [Core Lisp home]: http://www.p-cos.net/core-lisp.html 81 | [r6rs-imports]: http://www.r6rs.org/final/html/r6rs/r6rs-Z-H-10.html#node_chap_7 82 | [package-local nicknames]: http://sbcl.org/manual/index.html#Package_002dLocal-Nicknames 83 | [Grosskurth]: https://uwspace.uwaterloo.ca/handle/10012/2673 84 | [apenwarr]: https://github.com/apenwarr/redo 85 | [Ghuloum]: https://dl.acm.org/citation.cfm?id=1626863 86 | [submodules]: https://dl.acm.org/citation.cfm?id=2517211 87 | [YWIW]: https://dl.acm.org/citation.cfm?id=581486 88 | [Racket Manifesto]: http://www.ccs.neu.edu/home/matthias/manifesto/ 89 | [ISLISP]: http://islisp.info/ 90 | [Core Lisp]: http://github.com/ruricolist/core-lisp 91 | [SLIME]: http://common-lisp.net/project/slime/ 92 | [SLY]: https://github.com/joaotavora/sly 93 | [Gasbichler]: https://pdfs.semanticscholar.org/8af5/fbb7988f83baa5a6c3e93e0db4c381abfc3a.pdf 94 | [Bawden]: https://people.csail.mit.edu/alan/mtt/ 95 | [Frink]: https://frinklang.org 96 | [LoL]: http://www.letoverlambda.com/ 97 | [djb-redo]: https://cr.yp.to/redo.html 98 | [djb]: https://cr.yp.to/djb.html 99 | [Beautiful Racket]: http://beautifulracket.com 100 | [Maxima]: https://sourceforge.net/projects/maxima/ 101 | [ACL2]: https://www.cs.utexas.edu/users/moore/acl2/ 102 | [hopeless]: https://gist.github.com/samth/3083053 103 | [parser generator]: http://cliki.net/parser%20generator 104 | [Boot]: http://boot-clj.com 105 | [Make]: https://www.gnu.org/software/make/ 106 | [Roswell]: https://github.com/roswell/roswell 107 | [cl-launch]: http://cliki.net/cl-launch 108 | [dev]: https://github.com/ruricolist/overlord/tree/dev 109 | [Quicklisp]: https://www.quicklisp.org/beta/ 110 | [wiki]: https://github.com/ruricolist/overlord/wiki 111 | [parallelism]: https://github.com/ruricolist/overlord/wiki/Parallelism-in-Overlord 112 | [Proctor]: https://github.com/ruricolist/proctor 113 | [Vernacular]: https://github.com/ruricolist/vernacular 114 | [intro]: 115 | https://github.com/ruricolist/overlord/wiki/Overlord-for-Lispers 116 | [cli]: https://github.com/ruricolist/overlord-cli 117 | [harmful]: https://accu.org/journals/overload/14/71/miller_2004/ 118 | 119 | 121 | 122 | 123 | 124 | 125 | 126 | -------------------------------------------------------------------------------- /all.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :overlord/all 2 | (:nicknames :overlord) 3 | (:import-from :overlord/types 4 | :overlord-error :overlord-warning 5 | :overlord-error-target) 6 | (:export :overlord-error :overlord-warning) 7 | (:import-from :overlord/message 8 | :message 9 | :*message-stream*) 10 | (:import-from :overlord/util 11 | :write-file-if-changed 12 | :copy-file-if-changed 13 | :strip-directory) 14 | (:import-from :overlord/specials 15 | :use-threads-p #:*force* #:*jobs*) 16 | (:import-from :overlord/redo 17 | :recursive-dependency 18 | :missing-script 19 | :building? 20 | :redo-always) 21 | (:import-from :overlord/build-env :*use-build-cache*) 22 | (:import-from :overlord/kernel :nproc) 23 | 24 | (:export 25 | :*use-build-cache* 26 | :recursive-dependency :missing-script 27 | :module-ref :module-ref* :module-exports :module-static-exports 28 | :simple-module :hash-table-module 29 | :ensure-file-package :reset-file-package 30 | :message :*message-stream* 31 | :write-file-if-changed :copy-file-if-changed 32 | :strip-directory 33 | :use-threads-p :*force* 34 | :building? :redo-always 35 | :overlord-error-target :overlord-error 36 | :nproc :*jobs*) 37 | (:use-reexport 38 | :overlord/base 39 | :overlord/target 40 | :overlord/freeze 41 | :overlord/message 42 | :overlord/target-protocol 43 | :overlord/oracle 44 | :cmd 45 | :overlord/project-system)) 46 | 47 | (defpackage :overlord-user 48 | (:use :cl :alexandria :serapeum :overlord)) 49 | -------------------------------------------------------------------------------- /asdf.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/asdf 2 | (:documentation "This package contains wrappers for ASDF functions. 3 | 4 | The idea is to be able to trivially audit exactly how Overlord uses ASDF. 5 | 6 | If you want to call an ASDF function in another package, don't! Add a wrapper for it here and import that.") 7 | (:use :cl :alexandria :serapeum) 8 | (:import-from :named-readtables 9 | :find-readtable) 10 | (:import-from :overlord/types 11 | :error*) 12 | (:import-from :uiop 13 | :absolute-pathname-p) 14 | (:export 15 | :find-asdf-system 16 | :asdf-system-version 17 | :asdf-system-relative-pathname 18 | :package-name-asdf-system 19 | :package-inferred-asdf-system? 20 | :primary-asdf-system-name 21 | :asdf-system? 22 | :asdf-system-loaded? 23 | :load-asdf-system 24 | :asdf-system-base 25 | :require-asdf-system 26 | :asdf-system-name-keyword 27 | :asdf-system-name 28 | :asdf-system)) 29 | (in-package :overlord/asdf) 30 | 31 | (deftype asdf-system () 32 | 'asdf:system) 33 | 34 | ;;; Did you know that, in SBCL, calls to `asdf:find-system' from 35 | ;;; multiple threads can result in a deadlock, due to the fact that 36 | ;;; `uiop:coerce-class' calls `subtypep', which can lead to taking the 37 | ;;; world lock? Anyway, we shouldn't assume ASDF is thread-safe. 38 | (defun find-asdf-system (system &key error) 39 | (let ((*readtable* (find-readtable :standard)) 40 | (*read-base* 10) 41 | (*read-default-float-format* 'double-float)) 42 | (asdf:find-system system error))) 43 | 44 | (defun asdf-system-version (system &key error) 45 | (if-let (system (asdf:find-system system (not error))) 46 | (asdf:component-version system) 47 | nil)) 48 | 49 | (defun asdf-system-relative-pathname (system pathname) 50 | (asdf:system-relative-pathname system pathname)) 51 | 52 | (defun package-name-asdf-system (n) 53 | ;; XXX Internal symbol. 54 | (asdf/package-inferred-system::package-name-system n)) 55 | 56 | (defun package-inferred-asdf-system? (system) 57 | (typep system 'asdf:package-inferred-system)) 58 | 59 | (defun primary-asdf-system-name (system) 60 | (asdf:primary-system-name system)) 61 | 62 | (defun asdf-system? (system) 63 | (typep system 'asdf:system)) 64 | 65 | (defun asdf-system-name-keyword (system) 66 | (etypecase system 67 | (asdf:system 68 | (~> system 69 | asdf:component-name 70 | asdf-system-name-keyword)) 71 | (string 72 | (~> system 73 | string-upcase 74 | make-keyword)) 75 | (keyword system))) 76 | 77 | (defun asdf-system-name (system) 78 | (asdf:component-name (asdf:find-system system))) 79 | 80 | (defun asdf-system-loaded? (system) 81 | (let ((system (find-asdf-system system :error nil))) 82 | (and system 83 | (asdf:component-loaded-p system) 84 | system))) 85 | 86 | (defun load-asdf-system (system) 87 | (asdf:load-system system)) 88 | 89 | (defun asdf-system-base (system) 90 | (setf system (find-asdf-system system)) 91 | (let ((base (asdf-system-relative-pathname system ""))) 92 | (if (absolute-pathname-p base) base 93 | (if (package-inferred-asdf-system? system) 94 | (let* ((system-name (primary-asdf-system-name system)) 95 | (base-system-name (take-while (op (not (eql _ #\/))) system-name)) 96 | (base-system (find-asdf-system base-system-name))) 97 | (asdf-system-base base-system)) 98 | (error* "System ~a has no base." system))))) 99 | 100 | (defun require-asdf-system (system) 101 | ;; For some reason (why?) asdf:require-system is deprecated. 102 | (unless (asdf:component-loaded-p system) 103 | (asdf:load-system system))) 104 | -------------------------------------------------------------------------------- /base.lisp: -------------------------------------------------------------------------------- 1 | ;;;; The current base. 2 | 3 | (defpackage :overlord/base 4 | (:use :cl :alexandria :serapeum 5 | :overlord/types 6 | :overlord/global-state 7 | :overlord/asdf) 8 | (:import-from :overlord/specials 9 | :*base* :*cli* 10 | :*base-package* :base-package) 11 | (:import-from :uiop 12 | :pathname-directory-pathname 13 | :absolute-pathname-p 14 | :directory-pathname-p 15 | :merge-pathnames* 16 | :pathname-equal 17 | :*nil-pathname*) 18 | (:import-from :overlord/util 19 | :locate-dominating-file 20 | :ensure-pathname*) 21 | (:export 22 | :current-dir! 23 | :*base* :base 24 | :*base-package* :base-package 25 | :set-package-base 26 | :set-package-system 27 | :base-relative-pathname 28 | :ensure-absolute 29 | :with-current-dir 30 | :package-base 31 | :package-system 32 | :current-system 33 | :resolve-file)) 34 | 35 | (in-package :overlord/base) 36 | 37 | (defun absolute-directory-pathname? (x) 38 | "Is X an absolute directory pathname?" 39 | (and (absolute-pathname-p x) 40 | (directory-pathname-p x))) 41 | 42 | (defun ensure-absolute-directory-pathname (x) 43 | "Resolve X as an absolute directory pathname." 44 | (assure absolute-directory-pathname 45 | (if (absolute-directory-pathname? x) x 46 | (let ((x (truename x))) 47 | (if (directory-pathname-p x) x 48 | (pathname-directory-pathname x)))))) 49 | 50 | (-> current-dir! () absolute-directory-pathname) 51 | (defun current-dir! () 52 | "Return the current directory. 53 | 54 | If `*default-pathname-defaults*' is an absolute directory pathname, return that. 55 | 56 | Otherwise, resolve `*default-pathname-defaults*' to an absolute directory, set `*default-pathname-defaults*' to the new value, and return the new value." 57 | (let ((dpd *default-pathname-defaults*)) 58 | (if (absolute-directory-pathname? dpd) dpd 59 | (setf *default-pathname-defaults* 60 | (ensure-absolute-directory-pathname dpd))))) 61 | 62 | (defun (setf current-dir!) (dir) 63 | (lret ((dir (ensure-absolute-directory-pathname dir))) 64 | (ensure-directories-exist dir) 65 | (unless (pathname-equal dir *default-pathname-defaults*) 66 | (setf *default-pathname-defaults* dir)))) 67 | 68 | (defun call/current-dir (thunk dir) 69 | (ensure-directories-exist dir) 70 | (let ((*base* dir) 71 | (*default-pathname-defaults* *nil-pathname*)) 72 | (setf (current-dir!) dir) 73 | (funcall thunk))) 74 | 75 | (defmacro with-current-dir ((dir &key) &body body) 76 | (with-thunk (body) 77 | `(call/current-dir ,body ,dir))) 78 | 79 | (defun ensure-absolute (pathname &key (base (base))) 80 | (assure absolute-pathname 81 | (etypecase pathname 82 | (absolute-pathname pathname) 83 | (relative-pathname 84 | (merge-pathnames* pathname base))))) 85 | 86 | (defun resolve-file (file &key (base (base))) 87 | (~> file 88 | ensure-pathname* 89 | (ensure-absolute :base base))) 90 | 91 | (deftype package-base-spec () 92 | "One of the three ways of specifying the base of a package: (1) an 93 | absolute pathname, (2) a system (whose base should be used), or (3) 94 | a pair of a system and a relative pathname (in which case the 95 | relative pathname should be merged with the system base)." 96 | '(or 97 | asdf-system absolute-pathname 98 | (cons asdf-system relative-pathname))) 99 | 100 | (define-global-state *package-bases* 101 | (dict 'eql 102 | (find-package :cl-user) (user-homedir-pathname))) 103 | 104 | (defun package-base-spec (package) 105 | (check-type package package) 106 | (let ((table *package-bases*)) 107 | (synchronized (table) 108 | (href table package)))) 109 | 110 | (defun (setf package-base-spec) (spec package) 111 | (check-type package package) 112 | (check-type spec package-base-spec) 113 | (let ((table *package-bases*)) 114 | (synchronized (table) 115 | (setf (href table package) spec)))) 116 | 117 | (defun set-package-base-1 (package base system) 118 | "Set the base and/or system of PACKAGE." 119 | (setf package (find-package package)) 120 | (when system 121 | (setf system (find-asdf-system system :error t))) 122 | (econd 123 | ((and base system) 124 | (setf base 125 | (uiop:ensure-pathname base 126 | :want-directory t 127 | :want-pathname t 128 | :want-relative t)) 129 | (setf (package-base-spec package) 130 | (cons system base))) 131 | (system 132 | (set-package-system-1 package system)) 133 | (base 134 | (setf (package-base-spec package) 135 | (uiop:ensure-pathname base 136 | :want-directory t 137 | :want-pathname t 138 | :want-absolute t))) 139 | (t (error "No path or system.")))) 140 | 141 | (defun set-package-base* (base &optional system) 142 | "Set the base and/or system, for the current package." 143 | (set-package-base-1 (base-package) base system)) 144 | 145 | (defmacro set-package-base (base &optional system) 146 | "Set the base and/or system, for the current package, at compile 147 | time as well as load time." 148 | `(eval-always 149 | (set-package-base* ,base ,system))) 150 | 151 | (defun set-package-system-1 (package system) 152 | (let* ((package (find-package package)) 153 | (system (find-asdf-system system :error t))) 154 | (setf (package-base-spec package) system))) 155 | 156 | (defun set-package-system* (system) 157 | (set-package-system-1 *package* system)) 158 | 159 | (defmacro set-package-system (system) 160 | `(eval-always 161 | (set-package-system* ,system))) 162 | 163 | (defun base () 164 | "Return the current base, which is either the current value of 165 | `*base*' (if that is bound) or the base of the current package." 166 | #+(or) (or *compile-file-truename* *load-truename*) 167 | (ensure-absolute-directory-pathname 168 | (if (boundp '*base*) *base* 169 | (package-base (base-package))))) 170 | 171 | (defun saved-package-base (package) 172 | "If a base has been set for PACKAGE, return it." 173 | (setf package (find-package package)) 174 | (let ((spec (package-base-spec package))) 175 | (and spec 176 | (etypecase-of package-base-spec spec 177 | (asdf-system (asdf-system-base spec)) 178 | (absolute-pathname spec) 179 | ((cons asdf-system relative-pathname) 180 | (asdf-system-relative-pathname (car spec) (cdr spec))))))) 181 | 182 | (defun saved-package-system (package) 183 | "If a system has been set for PACKAGE, return it." 184 | (setf package (find-package package)) 185 | (let ((spec (package-base-spec package))) 186 | (and spec 187 | (etypecase-of package-base-spec spec 188 | (asdf-system spec) 189 | (absolute-pathname nil) 190 | ((cons asdf-system relative-pathname) 191 | (car spec)))))) 192 | 193 | (defun package-base (package &key (errorp t)) 194 | "Retrieve or infer the base of PACKAGE." 195 | (setf package (find-package package)) 196 | (let* ((base 197 | (or (saved-package-base package) 198 | (asdf-system-base 199 | (package-system package :errorp errorp))))) 200 | (if (absolute-pathname-p base) base 201 | (and errorp 202 | (error* "Cannot infer base.~%Package: ~a~%File: ~a" 203 | package 204 | (current-lisp-file)))))) 205 | 206 | (defun current-system () 207 | "Retrieve or infer the system the current package comes from." 208 | (package-system (base-package))) 209 | 210 | (defun package-system (package &key errorp) 211 | "Retrieve or infer the system PACKAGE comes from." 212 | (or (saved-package-system package) 213 | (infer-system package :errorp errorp))) 214 | 215 | (defun infer-system (package &key (errorp t)) 216 | (setf package (find-package package)) 217 | (assure (or null asdf-system) 218 | (or (infer-system-from-package package) 219 | (look-for-asd) 220 | (and errorp 221 | (setf (package-base-spec package) 222 | (progn 223 | (cerror* "Supply a system name" 224 | "Cannot infer a system for ~a. 225 | 226 | To avoid this error in the future, use ~s." 227 | (base-package) 228 | 'set-package-base) 229 | (read-system-by-name))))))) 230 | 231 | (defun read-system-by-name () 232 | (format t "~&Type a system name: ") 233 | (assure asdf-system 234 | (let ((name (make-keyword (string (read))))) 235 | (or (find-asdf-system name :error nil) 236 | (progn 237 | (cerror* "Supply another name" 238 | "No such system as ~a" name) 239 | (read-system-by-name)))))) 240 | 241 | (defun current-lisp-file () 242 | (or *compile-file-truename* *load-truename*)) 243 | 244 | (defun infer-system-from-package (&optional (package (base-package))) 245 | (or (infer-system-from-package-names package) 246 | (infer-system-from-package-affix package))) 247 | 248 | (defun infer-system-from-package-names (package) 249 | (some #'guess-system-from-package-name 250 | (package-names package))) 251 | 252 | (defun infer-system-from-package-affix (package) 253 | (let ((name (package-name package))) 254 | (or (and (find #\/ name) 255 | (let ((prefix (first (split-sequence #\/ name :count 1)))) 256 | (and prefix 257 | (guess-system-from-package-name 258 | (string-downcase prefix))))) 259 | (let ((-user "-USER")) 260 | (and (string$= -user name) 261 | (let ((pkg 262 | (find-package 263 | (slice name 0 (- (length -user)))))) 264 | (and pkg 265 | (infer-system-from-package pkg)))))))) 266 | 267 | (defun guess-system-from-package-name (name) 268 | (when-let (guess (package-name-asdf-system name)) 269 | (find-asdf-system guess :error nil))) 270 | 271 | (defun look-for-asd () 272 | "Look for the nearest .asd file and return its name." 273 | (and-let* ((file (current-lisp-file)) 274 | ((not (typep file 'temporary-file))) 275 | (.asd (nearest-asdf-file file))) 276 | (find-asdf-system (pathname-name .asd) :error nil))) 277 | 278 | (defun nearest-asdf-file (file) 279 | (locate-dominating-file file "*.asd")) 280 | -------------------------------------------------------------------------------- /build-env.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/build-env 2 | (:documentation "Environment for builds, including (but not limited 3 | to) caching already built targets.") 4 | (:use :cl :alexandria :serapeum 5 | :overlord/target-protocol 6 | :overlord/target-table) 7 | (:import-from :bordeaux-threads 8 | :make-lock 9 | :make-recursive-lock 10 | :with-lock-held 11 | :with-recursive-lock-held) 12 | (:import-from :fset) 13 | (:import-from :lparallel 14 | :*kernel* 15 | :broadcast-task 16 | :end-kernel 17 | :invoke-transfer-error 18 | :make-channel 19 | :make-kernel 20 | :no-kernel-error 21 | :receive-result 22 | :submit-task 23 | :task-handler-bind) 24 | (:import-from :lparallel.kernel-util 25 | :with-temp-kernel) 26 | (:import-from :lparallel.queue 27 | :make-queue 28 | :push-queue 29 | :queue-count 30 | :try-pop-queue) 31 | (:import-from :overlord/db 32 | :require-db 33 | :saving-database) 34 | (:import-from :overlord/kernel 35 | :nproc) 36 | (:import-from :overlord/message 37 | :*message-stream* 38 | :message) 39 | (:import-from :overlord/specials 40 | :register-worker-special 41 | :use-threads-p) 42 | (:import-from :overlord/stamp 43 | :never) 44 | (:import-from :overlord/types 45 | :error*) 46 | (:import-from :uiop 47 | :absolute-pathname-p 48 | :process-alive-p 49 | :terminate-process 50 | :wait-process) 51 | (:export :*use-build-cache* 52 | :ask-for-token* 53 | :build-env-bound? 54 | :cached-stamp 55 | :claim-file* 56 | :claim-files* 57 | :register-proc* 58 | :return-token* 59 | :target-exists?/cache 60 | :target-locked-p 61 | :target-stamp/cache 62 | :temp-prereqs 63 | :temp-prereqsne 64 | :with-build-env)) 65 | (in-package :overlord/build-env) 66 | 67 | (defvar *use-build-cache* t 68 | "Should we cache which targets are already built? 69 | 70 | Note that this can safely be rebound around part of a build when 71 | non-caching behavior is desired.") 72 | (register-worker-special '*use-build-cache*) 73 | 74 | (defvar *build-id* 0) 75 | 76 | (defun next-build-id () 77 | (synchronized () 78 | (incf *build-id*))) 79 | 80 | (defvar-unbound *build-env* 81 | "Environment for the current build.") 82 | (register-worker-special '*build-env*) 83 | 84 | (defun use-build-cache? () 85 | *use-build-cache*) 86 | 87 | (defun build-env-bound? () 88 | (boundp '*build-env*)) 89 | 90 | (defclass build-env () 91 | ((lock :initform (make-recursive-lock) 92 | :reader monitor) 93 | (id :type (integer 1 *) 94 | :initform (next-build-id)) 95 | (table 96 | :initform (make-target-table) 97 | :reader build-env.table) 98 | (file-owners 99 | :initform (dict) 100 | :reader build-env.file-owners) 101 | (procs 102 | :initform nil 103 | :accessor build-env-procs 104 | :documentation "Processes being run asynchronously.")) 105 | (:documentation "Metadata for the build run.")) 106 | 107 | (defmethod print-object ((self build-env) stream) 108 | (print-unreadable-object (self stream :type t) 109 | (with-slots (id) self 110 | (format stream "#~a" id)))) 111 | 112 | ;;; Claiming files. 113 | 114 | (defmethod claim-file ((self build-env) target (file pathname)) 115 | (claim-files self target (list file))) 116 | 117 | (defmethod claim-files ((self build-env) target (files sequence)) 118 | (assert (every #'absolute-pathname-p files)) 119 | (nest 120 | (with-slots (file-owners) self) 121 | #-ccl (synchronized (self)) 122 | (do-each (file files) 123 | (let ((owner 124 | (ensure-gethash file file-owners target))) 125 | (unless (target= owner target) 126 | (error* "~ 127 | Target ~a wants to build ~a, but it has already been built by ~a." 128 | target file owner)))))) 129 | 130 | (defun claim-file* (target file) 131 | (claim-file *build-env* target file)) 132 | 133 | (defun claim-files* (target files) 134 | (claim-files *build-env* target files)) 135 | 136 | ;;; Tracking processes (so they can be shut down on abnormal exit). 137 | 138 | (defun register-proc* (proc) 139 | (when (build-env-bound?) 140 | (register-proc *build-env* proc))) 141 | 142 | (defmethod register-proc ((env build-env) proc) 143 | "Remember PROC in ENV. Return PROC." 144 | (synchronized (env) 145 | (push proc (build-env-procs env))) 146 | proc) 147 | 148 | (defmethod kill-procs ((env build-env) &key urgent) 149 | "Kill all live processes tracked by ENV." 150 | (do-each (proc (build-env-procs env)) 151 | (when (process-alive-p proc) 152 | (terminate-process proc :urgent urgent)))) 153 | 154 | (defmethod await-procs ((env build-env)) 155 | "Wait for processes tracked by ENV to exit." 156 | (do-each (proc (build-env-procs env)) 157 | (wait-process proc))) 158 | 159 | (defmethod call-with-procs-tracked ((env build-env) (fn function)) 160 | (let ((abnormal? t)) 161 | (unwind-protect 162 | (multiple-value-prog1 (funcall fn) 163 | (setf abnormal? nil)) 164 | (when (some #'process-alive-p (build-env-procs env)) 165 | (message "Waiting for launched programs...") 166 | (force-output *message-stream*)) 167 | (when abnormal? 168 | (kill-procs env)) 169 | (await-procs env)))) 170 | 171 | (defmacro with-procs-tracked ((env) &body body) 172 | (with-thunk (body) 173 | `(call-with-procs-tracked ,env ,body))) 174 | 175 | (defclass threaded-build-env (build-env) 176 | ((jobs :initarg :jobs :type (integer 1 *)) 177 | (tokens :reader build-env-tokens) 178 | (jobs-used :initform 1) 179 | (handler 180 | :type function 181 | :initarg :handler)) 182 | (:default-initargs 183 | :jobs nproc 184 | :handler #'invoke-transfer-error)) 185 | 186 | (defmethod track-jobs-used ((env threaded-build-env)) 187 | "This should be used after a token is obtained to track how many 188 | threads are being used. 189 | 190 | The idea is to be able to tell how many of the allocated threads are 191 | actually being used, so we know how many to allocate for the next run." 192 | (with-slots (jobs-used jobs tokens) env 193 | (let* ((length (1- jobs)) 194 | (count (queue-count tokens)) 195 | (used (- length count))) 196 | (maxf jobs-used (1+ used))))) 197 | 198 | (defmethod initialize-instance :after ((self threaded-build-env) &key) 199 | (with-slots (jobs tokens) self 200 | (setf tokens (make-token-pool (1- jobs))))) 201 | 202 | (defun make-build-env (&key jobs handler) 203 | (if (use-threads-p) 204 | (make 'threaded-build-env :jobs jobs :handler handler) 205 | (make 'build-env))) 206 | 207 | (defstruct (target-meta 208 | (:conc-name target-meta.) 209 | (:constructor make-target-meta (target))) 210 | (target (error "No target") 211 | :read-only t) 212 | (stamp nil) 213 | (lock (bt:make-lock)) 214 | (lockedp nil :type boolean) 215 | (temp-prereqs (fset:empty-map) :type fset:map) 216 | (temp-prereqsne (fset:empty-set) :type fset:set)) 217 | 218 | (defplace temp-prereqs (target) 219 | (target-meta.temp-prereqs (target-meta target))) 220 | 221 | (defplace temp-prereqsne (target) 222 | (target-meta.temp-prereqsne (target-meta target))) 223 | 224 | (defun call/build-env (fn &key jobs debug) 225 | (if (build-env-bound?) 226 | (funcall fn) 227 | (let* ((handler 228 | (if debug 229 | #'invoke-debugger 230 | #'invoke-transfer-error)) 231 | (env (make-build-env :jobs jobs 232 | :handler handler))) 233 | (call-in-build-env env fn)))) 234 | 235 | (defgeneric call-in-build-env (env fn)) 236 | 237 | (defmethod call-in-build-env (env fn) 238 | (with-slots (id) env 239 | (let ((*build-env* env)) 240 | (with-procs-tracked (env) 241 | ;; The DB cannot be loaded from within worker threads. 242 | (saving-database 243 | (funcall fn)))))) 244 | 245 | (defmethod make-env-kernel ((env threaded-build-env) thread-count) 246 | (with-slots (jobs id) env 247 | (message "Initializing ~a thread~:p for build ~a." 248 | thread-count 249 | id) 250 | (let ((kernel-name (fmt "Kernel for build ~a." id))) 251 | (make-kernel thread-count 252 | :name kernel-name 253 | :context (lambda (fn) 254 | (nest 255 | ;; Propagate the build env here. 256 | (let ((*build-env* env))) 257 | ;; Give each thread its own random state. 258 | ;; (Clozure CL, at least, gives every 259 | ;; thread the same initial random state. 260 | ;; This can cause race conditions when 261 | ;; generating temporary file names.) 262 | (let ((*random-state* (make-random-state t)))) 263 | (funcall fn))))))) 264 | 265 | (defmethod call-in-build-env ((env threaded-build-env) fn) 266 | (declare (ignore fn)) 267 | (require-db) 268 | (with-slots (jobs id tokens jobs-used handler) env 269 | (let ((thread-count (max 1 (1- jobs)))) 270 | (if (zerop thread-count) (call-next-method) 271 | (let ((*kernel* nil)) 272 | (with-procs-tracked (env) 273 | (unwind-protect 274 | ;; Initialize the kernel lazily. 275 | (handler-bind ((no-kernel-error 276 | (lambda (e) (declare (ignore e)) 277 | (synchronized (env) 278 | (unless *kernel* 279 | (invoke-restart 280 | 'store-value 281 | (make-env-kernel env thread-count))))))) 282 | (task-handler-bind ((error handler)) 283 | (multiple-value-prog1 (call-next-method) 284 | (message "A maximum of ~a/~a jobs were used." 285 | jobs-used jobs)))) 286 | (when *kernel* 287 | (end-kernel :wait t))))))))) 288 | 289 | (defmacro with-build-env ((&key (jobs 'nproc) debug) &body body) 290 | (with-thunk (body) 291 | `(call/build-env ,body :jobs ,jobs :debug ,debug))) 292 | 293 | (defun target-meta (target) 294 | (let* ((table (build-env.table *build-env*))) 295 | (or (target-table-ref table target) 296 | (synchronized (table) 297 | (ensure (target-table-ref table target) 298 | (make-target-meta target)))))) 299 | 300 | (defmacro with-target-meta-locked ((target &key) &body body) 301 | (with-thunk (body) 302 | `(call-with-target-meta-locked ,target ,body))) 303 | 304 | (defun call-with-target-meta-locked (target fn) 305 | (if (not (build-env-bound?)) (funcall fn) 306 | (let* ((meta (target-meta target)) 307 | (lock (target-meta.lock meta))) 308 | (bt:with-lock-held (lock) 309 | (setf (target-meta.lockedp meta) t) 310 | (unwind-protect 311 | (funcall fn) 312 | (setf (target-meta.lockedp meta) nil)))))) 313 | 314 | (defmethod call-with-target-locked (target fn) 315 | "Make call-with-target-meta-locked the default for call-with-target-locked." 316 | (with-target-meta-locked (target) 317 | (funcall fn))) 318 | 319 | (defun target-locked-p (target) 320 | (target-meta.lockedp (target-meta target))) 321 | 322 | (defun cached-stamp (target) 323 | (when (build-env-bound?) 324 | (if (use-build-cache?) 325 | (target-meta.stamp (target-meta target)) 326 | ;; If we are not using the cache, then we still want to 327 | ;; invalidate it, so subsequent build steps will be consistent 328 | ;; with the current one. 329 | (setf (cached-stamp target) nil)))) 330 | 331 | (defun (setf cached-stamp) (value target) 332 | (prog1 value 333 | (when (build-env-bound?) 334 | (setf (target-meta.stamp (target-meta target)) 335 | (if (use-build-cache?) 336 | value 337 | ;; If we are not using the cache, then the cache should 338 | ;; still be invalidated, so subsequent build steps are 339 | ;; consistent with the current one. 340 | nil))))) 341 | 342 | (defun target-exists?/cache (target) 343 | "Skip hitting the filesystem to check if a target exists if we 344 | already built it." 345 | (or (and (build-env-bound?) 346 | (use-build-cache?) 347 | (let ((stamp (cached-stamp target))) 348 | (unless (eql stamp never) 349 | (true stamp)))) 350 | (target-exists? target))) 351 | 352 | (defun target-stamp/cache (target) 353 | "Skip hitting the filesystem to check a target's stamp if we already 354 | built it." 355 | (or (and (build-env-bound?) 356 | (use-build-cache?) 357 | (cached-stamp target)) 358 | (target-stamp target))) 359 | 360 | ;;; How jobs are parallelized. This is intended to be spiritually (and 361 | ;;; eventually technically) compatible with Make's jobserver protocol. 362 | ;;; We are still using Lparallel, but only as a thread pool; we ignore 363 | ;;; its scheduler. Instead, we use a fixed pool of tokens. 364 | 365 | (deftype token () 366 | '(integer 0 *)) 367 | 368 | (defun make-token-pool (n) 369 | (let ((n (max 1 n))) 370 | (make-queue :fixed-capacity n 371 | :initial-contents (range n)))) 372 | 373 | (-> ask-for-token (t) (or token null)) 374 | (defun ask-for-token (env) 375 | (lret* ((queue (build-env-tokens env)) 376 | (token (try-pop-queue queue))) 377 | (track-jobs-used env))) 378 | 379 | (defun ask-for-token* () 380 | "Get a token from the current build environment." 381 | (ask-for-token *build-env*)) 382 | 383 | (-> return-token (t token) (values)) 384 | (defun return-token (env token) 385 | (push-queue token (build-env-tokens env)) 386 | (values)) 387 | 388 | (defun return-token* (token) 389 | "Return TOKEN to the current build environment." 390 | (return-token *build-env* token)) 391 | -------------------------------------------------------------------------------- /cache.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/cache 2 | (:use :cl :alexandria :serapeum 3 | :overlord/types) 4 | (:import-from :overlord/specials :db-version) 5 | (:import-from :uiop 6 | :os-windows-p 7 | :xdg-cache-home 8 | :ensure-directory-pathname) 9 | (:export 10 | :current-cache-dir 11 | :make-shadow-tree 12 | :shadow-tree-translate)) 13 | (in-package :overlord/cache) 14 | 15 | (defstruct-read-only (shadow-tree (:constructor %make-shadow-tree)) 16 | "First-class shadow trees. 17 | 18 | A shadow tree is a hidden directory structure (like that used by ASDF 19 | to store fasls) whose subdirectories recapitulate the filesystem 20 | hierarchy from the top level. 21 | 22 | Shadow trees are useful for caching files that depend in some 23 | deterministic way on top-level files." 24 | (prefix :type list)) 25 | 26 | (defsubst make-shadow-tree (&key prefix) 27 | "Make a shadow tree with prefix PREFIX. 28 | PREFIX may be a string or a list of strings." 29 | (let ((prefix (ensure-list prefix))) 30 | (assert (every #'stringp prefix)) 31 | (%make-shadow-tree :prefix prefix))) 32 | 33 | (defun shadow-tree-translate (tree path) 34 | "Return a path equivalent to PATH in shadow tree TREE. 35 | PATH must be an absolute path." 36 | (path-join 37 | (shadow-tree-root tree) 38 | (absolute-path-shadow-tree-suffix path))) 39 | 40 | (defun shadow-tree-root (shadow-tree) 41 | "Get the root directory of SHADOW-TREE." 42 | (assure (and absolute-pathname directory-pathname) 43 | (let ((prefix (shadow-tree-prefix shadow-tree))) 44 | (path-join 45 | (current-cache-dir) 46 | (make-pathname 47 | :directory `(:relative ,@prefix)))))) 48 | 49 | (defun current-cache-dir (&optional (version (db-version))) 50 | "The current Overlord cache directory. 51 | The path includes the Overlord major version, as well as the Lisp 52 | implementation and version, so if Overlord is updated, or the Lisp 53 | implementation is upgraded, the old cache is automatically 54 | invalidated." 55 | (ensure-directory-pathname 56 | (xdg-cache-home "overlord" 57 | (fmt "v~a" (assure db-version version)) 58 | :implementation))) 59 | 60 | (defun absolute-path-shadow-tree-suffix (path) 61 | "Turn PATH, an absolute pathname, into a relative pathname whose 62 | directory components are the same as the directory components of 63 | PATH. 64 | 65 | On Windows the suffix includes the device as a directory component." 66 | (check-type path absolute-pathname) 67 | (assure relative-pathname 68 | (~>> path 69 | pathname-directory 70 | (drop-while #'keywordp) 71 | (append (list :relative) 72 | (if-let (device 73 | (and (os-windows-p) 74 | (pathname-device path))) 75 | (ensure-list device) 76 | nil)) 77 | (make-pathname 78 | :defaults path 79 | :device :unspecific 80 | :directory)))) 81 | -------------------------------------------------------------------------------- /db.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/db 2 | (:use :cl :alexandria :serapeum 3 | :overlord/specials 4 | :overlord/types 5 | :overlord/message 6 | :overlord/global-state 7 | :overlord/cache 8 | :overlord/asdf) 9 | (:import-from :uiop 10 | :implementation-type 11 | :with-temporary-file 12 | :rename-file-overwriting-target 13 | :file-exists-p 14 | :xdg-cache-home 15 | :subpathp 16 | :ensure-directory-pathname 17 | :merge-pathnames* 18 | :pathname-directory-pathname 19 | :delete-file-if-exists 20 | :directory-exists-p 21 | :delete-directory-tree 22 | :register-image-dump-hook 23 | :pathname-parent-directory-pathname) 24 | (:import-from :bordeaux-threads 25 | :make-thread) 26 | (:import-from :trivial-file-size :file-size-in-octets) 27 | (:import-from :fset) 28 | (:import-from :local-time) 29 | (:import-from :lparallel 30 | :kernel-worker-index) 31 | (:import-from :exit-hooks 32 | :add-exit-hook) 33 | (:import-from :overlord/util 34 | :withf :lessf) 35 | (:export 36 | :prop :has-prop? :delete-prop 37 | :save-database 38 | :saving-database 39 | :unload-db 40 | :deactivate-db 41 | :delete-versioned-db 42 | :db-loaded? 43 | :require-db)) 44 | (in-package :overlord/db) 45 | 46 | ;;; The database is a single file, an append-only log. If the log is 47 | ;;; too long, it is compacted during the initial load. 48 | 49 | ;;; The log is stored at a path that incorporates the Lisp 50 | ;;; implementation and version, as well as the Overlord version. 51 | ;;; Different Lisps get their own databases, and changes to the Lisp 52 | ;;; version, or the Overlord version, automatically result in a clean 53 | ;;; database. 54 | 55 | ;;; Any change to the database format should be accompanied by bumping 56 | ;;; the Overlord version. (This is, in fact, why Overlord is 57 | ;;; versioned.) 58 | 59 | ;;; The database is thread-safe within a single Lisp instance, but it 60 | ;;; should not be accessed from multiple Lisp instances 61 | ;;; simultaneously. 62 | 63 | ;;; At the moment database records are just Lisp objects, written with 64 | ;;; `write' and read in with `read'. This is more than fast enough. If 65 | ;;; this becomes an impediment, the next step would be to introduce 66 | ;;; streaming compression, so each record is compressed as it is 67 | ;;; written to disk. (This might require zlib.) Only if that becomes 68 | ;;; an impediment would be worthwhile to introduce a binary format. 69 | 70 | (defvar *save-pending* nil 71 | "Is there a save pending?") 72 | 73 | (deftype db-key () 74 | "Type of database keys." 75 | '(not null)) 76 | 77 | (deftype db-value () 78 | "Type for database values." 79 | 't) 80 | 81 | (defcondition db-error (overlord-error) 82 | ()) 83 | 84 | (defcondition version-mismatch (db-error) 85 | ((new-version :initarg :new-version) 86 | (old-version :initarg :old-version)) 87 | (:report (lambda (c s) 88 | (with-slots (new-version old-version) c 89 | (format s "Database version mismatch: wanted ~a, got ~a." 90 | new-version 91 | old-version))))) 92 | 93 | (defcondition locked-db (db-error) 94 | ((saved-pid :initarg :saved-pid)) 95 | (:report (lambda (c s) 96 | (with-slots (pid saved-pid) c 97 | (format s "The database is already locked by another process (pid ~a)." 98 | saved-pid))))) 99 | 100 | (defun db-error (control-str &rest args) 101 | (make-condition 'db-error 102 | :format-control control-str 103 | :format-arguments args)) 104 | 105 | (define-compiler-macro db-error (&whole call control-str &rest args) 106 | (if (stringp control-str) 107 | `(db-error (formatter ,control-str) ,@args) 108 | call)) 109 | 110 | (defgeneric db.ref (db key) 111 | (:documentation "Lookup KEY in DB.")) 112 | 113 | (defgeneric (setf db.ref) (value db key) 114 | (:documentation "Set the value of KEY in DB.")) 115 | 116 | (defgeneric db.del (db key) 117 | (:documentation "Delete a key in the database.")) 118 | 119 | (defgeneric db.sync (db) 120 | (:documentation "Sync the database to disk.")) 121 | 122 | (defgeneric lock-db (db) 123 | (:documentation "Create a lockfile for the DB.") 124 | (:method ((db t)) nil)) 125 | 126 | (defgeneric unlock-db (db) 127 | (:documentation "Remove the lockfile for the DB.") 128 | (:method ((db t)) nil)) 129 | 130 | (defunit tombstone "A tombstone value.") 131 | 132 | (defstruct-read-only (log-record (:conc-name log-record.)) 133 | "A single record in a log file." 134 | (timestamp (get-universal-time) :type (integer 0 *)) 135 | (data :type fset:map)) 136 | 137 | (defstruct-read-only (log-data (:conc-name log-data.)) 138 | "The data recovered from a log file." 139 | (map-count 0 :type (integer 0 *)) 140 | (map (fset:empty-map) :type fset:map)) 141 | 142 | (def no-log-data (make-log-data) 143 | "An empty set of log data.") 144 | 145 | (defun delete-versioned-db (&key (version (db-version))) 146 | "Delete a specific version of the database. 147 | The database is always implicitly versioned." 148 | (let ((dir (pathname-parent-directory-pathname (current-cache-dir version)))) 149 | (when (directory-exists-p dir) 150 | (delete-directory-tree 151 | dir 152 | :validate (op (subpathp _ (xdg-cache-home))))))) 153 | 154 | ;;; NB. This is a structure rather than a CLOS class so the slots work 155 | ;;; with SBCL's compare-and-swap. 156 | (defstruct (db (:conc-name db.)) 157 | "The database." 158 | (version (db-version) :read-only t) 159 | (log-file (log-file-path) :type pathname :read-only t) 160 | (current-map (fset:empty-map) :type fset:map) 161 | (last-saved-map (fset:empty-map) :type fset:map)) 162 | 163 | (defun db-alist (&optional (db (db))) 164 | "Return the database's data as an alist. 165 | For debugging." 166 | (let ((map (db.current-map db))) 167 | (collecting 168 | (fset:do-map (k v map) 169 | (collect (cons k v)))))) 170 | 171 | (-> log-file-size (pathname) (integer 0 *)) 172 | (defun log-file-size (log-file) 173 | "Return the size on disk of LOG-FILE." 174 | (if (file-exists-p log-file) 175 | (or (values (file-size-in-octets log-file)) 176 | 0) 177 | 0)) 178 | 179 | (defmethods db (db (version #'db.version) 180 | (log-file #'db.log-file) 181 | (current-map #'db.current-map) 182 | (last-saved-map #'db.last-saved-map)) 183 | (:method print-object (db stream) 184 | (print-unreadable-object (db stream :type t) 185 | ;; version record-count byte-count saved or not? 186 | (format stream "v.~a ~d record~:p, ~:d byte~:p~@[ (~a)~]" 187 | version 188 | (fset:size current-map) 189 | (log-file-size log-file) 190 | (and (not (eql current-map last-saved-map)) 191 | "unsaved")))) 192 | 193 | (:method db.ref (db key) 194 | (receive (value bool) 195 | (fset:lookup current-map 196 | (assure db-key key)) 197 | (if (eq value tombstone) 198 | (values nil nil) 199 | (values (assure db-value value) 200 | (assure boolean bool))))) 201 | 202 | (:method (setf db.ref) (value db key) 203 | (check-type key db-key) 204 | (check-type value db-value) 205 | (prog1 value 206 | ;; TODO More CAS. 207 | #+sbcl 208 | (sb-ext:atomic-update (db.current-map db) 209 | (lambda (map) 210 | (fset:with map key value))) 211 | #-sbcl 212 | (synchronized (db) 213 | (withf current-map key value)))) 214 | 215 | (:method db.del (db key) 216 | (setf (db.ref db key) tombstone) 217 | (values)) 218 | 219 | (:method db.sync (db) 220 | (let ((output *message-stream*)) 221 | (flet ((sync () 222 | (synchronized (db) 223 | (when (append-to-log log-file 224 | last-saved-map 225 | current-map) 226 | (setf last-saved-map current-map) 227 | (let ((*message-stream* output)) 228 | (message "Wrote database")))))) 229 | (if (use-threads-p) 230 | (make-thread #'sync :name "Overlord: saving database") 231 | (sync))))) 232 | 233 | (:method db.lock-file (db) 234 | (make-pathname :type "lock" :defaults log-file)) 235 | 236 | (:method lock-db (db) 237 | ;; XXX This locking scheme is currently effectively disabled. 238 | (let* ((file (db.lock-file db)) 239 | (pid (or (getpid) 240 | ;; Just in case we missed one. 241 | (load-time-value 242 | (let ((*random-state* (make-random-state t))) 243 | (random 1000000)))))) 244 | (ensure-directories-exist file) 245 | (tagbody 246 | :retry 247 | (handler-case 248 | (let* ((dir (pathname-directory-pathname file)) 249 | (tmpfile 250 | (uiop:with-temporary-file (:pathname p 251 | :directory dir 252 | :keep t) 253 | (with-output-to-file (out p 254 | :external-format :ascii 255 | :if-exists :overwrite) 256 | ;; "HDB UUCP lock file format" (according to the FHS). 257 | (format out "~10d~%" pid)) 258 | p))) 259 | (uiop:rename-file-overwriting-target tmpfile file)) 260 | (file-error (e) 261 | (go :try))) 262 | :try 263 | (let ((saved-pid 264 | (parse-integer 265 | (read-file-into-string file 266 | :external-format :ascii)))) 267 | (unless (= saved-pid pid) 268 | ;; (cerror "Steal the database" 269 | ;; 'locked-db 270 | ;; :saved-pid saved-pid) 271 | ;; (message "Database was locked by ~a, stealing." saved-pid) 272 | (delete-file-if-exists file) 273 | (go :retry)))))) 274 | 275 | (:method unlock-db (db) 276 | (delete-file-if-exists (db.lock-file db)))) 277 | 278 | (defun getpid () 279 | ;; Adapted from the sources of Sly. Should there be a trivial-getpid 280 | ;; library? 281 | #+ccl (ccl::getpid) 282 | #+sbcl (sb-posix:getpid) 283 | #+ecl (ext:getpid) 284 | #+clisp (os:process-id) 285 | #+cmucl (unix:unix-getpid) 286 | #+abcl (ext:get-pid) 287 | #+allegro (excl.osi:getpid) 288 | #+(and lispworks win32) (win32:get-current-process-id) 289 | #+(and lispworks (not win32)) 290 | (system::getpid) 291 | #+mkcl (mkcl:getpid) 292 | #+scl (unix:unix-getpid) 293 | #+clasp (si:getpid) 294 | #+cormanlisp ccl:*current-process-id*) 295 | 296 | (defstruct (dead-db (:include db) 297 | (:conc-name db.)) 298 | (state nil :type null :read-only t)) 299 | 300 | (defmethods dead-db (self) 301 | (:method db.ref (self key) 302 | (declare (ignore key)) 303 | (values nil nil)) 304 | (:method (setf db.ref) (value self key) 305 | (declare (ignore key)) 306 | value) 307 | (:method db.del (self key) 308 | (declare (ignore key)) 309 | (values)) 310 | (:method db.sync (self) 311 | (values))) 312 | 313 | (def db-readtable 314 | ;; Extend the readtable with local-time and fset. 315 | (lret ((*readtable* 316 | (copy-readtable fset::*fset-rereading-readtable*))) 317 | (local-time:enable-read-macros)) 318 | "The readtable for reading back the log.") 319 | 320 | (defun call/standard-io-syntax (fn) 321 | "Like `with-standard-io-syntax', but if there is an error, unwind 322 | the stack so the error itself can be printed." 323 | (values-list 324 | (funcall 325 | (block escape 326 | (handler-bind ((serious-condition 327 | (lambda (e) 328 | (return-from escape 329 | (lambda () 330 | (error e)))))) 331 | (with-standard-io-syntax 332 | (constantly (multiple-value-list (funcall fn))))))))) 333 | 334 | (defmacro with-standard-io-syntax* (&body body) 335 | "Macro wrapper for `call/standard-io-syntax'." 336 | (with-thunk (body) 337 | `(call/standard-io-syntax ,body))) 338 | 339 | (defun db-write (obj stream) 340 | "Write OBJ to STREAM using the database syntax." 341 | (with-standard-io-syntax* 342 | ;; It's possible a writer may look at the current readtable. 343 | (let ((*readtable* db-readtable)) 344 | (write obj :stream stream 345 | :readably t 346 | :pretty nil 347 | :circle nil)))) 348 | 349 | (-> append-to-log (t fset:map fset:map) boolean) 350 | (defun append-to-log (log last-saved-map current-map) 351 | "Compute the difference between CURRENT-MAP and LAST-SAVED-MAP and 352 | write it into LOG. 353 | 354 | If there is no difference, write nothing. 355 | 356 | Return T if something was written, nil otherwise." 357 | (unless (eql last-saved-map current-map) 358 | (let ((diff 359 | ;; This returns just the pairs that are new in current-map 360 | (fset:map-difference-2 current-map last-saved-map))) 361 | (unless (fset:empty? diff) 362 | (let ((record (make-log-record :data diff))) 363 | (with-output-to-file (out (ensure-directories-exist log) 364 | :element-type 'character 365 | :if-does-not-exist :create 366 | :if-exists :append) 367 | (db-write record out) 368 | (finish-output out) 369 | t)))))) 370 | 371 | (defun strip-tombstones (map) 372 | "Strip key-value pairs with tombstone values from MAP." 373 | (let ((out map)) 374 | (fset:do-map (k v map) 375 | (when (eq v tombstone) 376 | (lessf out k))) 377 | out)) 378 | 379 | (defun load-log-data (log-file) 380 | "Load the data from LOG-FILE." 381 | (declare (optimize safety debug)) 382 | (if (not (file-exists-p log-file)) 383 | no-log-data 384 | (tagbody 385 | :retry 386 | (restart-case 387 | (return-from load-log-data 388 | (with-standard-input-syntax 389 | (let* ((*readtable* db-readtable) 390 | (records 391 | (with-input-from-file (in log-file :element-type 'character) 392 | (let ((eof "eof")) 393 | (nlet rec ((records '())) 394 | (let ((data (read in nil eof))) 395 | (cond ((eq data eof) 396 | (nreverse records)) 397 | ((typep data 'log-record) 398 | (rec (cons data records))) 399 | (t 400 | (error (db-error "Invalid database log entry: ~a" 401 | data))))))))) 402 | (maps 403 | (mapcar #'log-record.data records)) 404 | (map 405 | (reduce #'fset:map-union maps 406 | :initial-value (fset:empty-map))) 407 | (map (strip-tombstones map))) 408 | (make-log-data 409 | :map map 410 | :map-count (length maps))))) 411 | (retry () 412 | :report "Try loading the database again." 413 | (go :retry)) 414 | (truncate-db () 415 | :report "Treat the database as corrupt and discard it." 416 | (delete-file-if-exists log-file) 417 | no-log-data))))) 418 | 419 | (defun squash-data (log-data log-file) 420 | "If needed, write a compacted version of LOG-DATA into LOG-FILE." 421 | (let ((map (log-data.map log-data)) 422 | (map-count (log-data.map-count log-data)) 423 | temp) 424 | (when (> map-count 1) 425 | (message "Compacting log-file") 426 | (with-temporary-file (:stream s 427 | :pathname p 428 | :keep t 429 | :direction :output 430 | :element-type 'character 431 | ;; Ensure the temp file is on the 432 | ;; same file system as the log-file so the 433 | ;; rename is atomic. 434 | :directory (pathname-directory-pathname log-file)) 435 | (setq temp p) 436 | (db-write (make-log-record :data map) s)) 437 | (rename-file-overwriting-target temp log-file)) 438 | log-file)) 439 | 440 | (defun log-file-path (&optional (version (db-version))) 441 | "Compute the path of the log file for the current database version." 442 | (assure absolute-pathname 443 | (path-join 444 | (current-cache-dir version) 445 | #p"log/" 446 | #p"log.sexp"))) 447 | 448 | (defun reload-db () 449 | "Reload the current version of the database from its log file." 450 | (when (in-worker?) 451 | (error (db-error "Cannot load the DB from within a worker."))) 452 | (lret* ((log-file (log-file-path)) 453 | (log-data 454 | (progn 455 | (message "Reloading database (~:d byte~:p)" 456 | (log-file-size log-file)) 457 | (load-log-data log-file))) 458 | (map (log-data.map log-data)) 459 | (db (make-db 460 | :log-file log-file 461 | :current-map map 462 | :last-saved-map map))) 463 | (make-thread 464 | (lambda () 465 | (synchronized (db) 466 | (squash-data log-data log-file))) 467 | :name "Overlord: compacting log file"))) 468 | 469 | (define-global-state *db* nil 470 | "The database.") 471 | (register-worker-special '*db*) 472 | 473 | (defun in-worker? () 474 | (true (kernel-worker-index))) 475 | 476 | (defun db () 477 | "Get the current database, loading it if necessary." 478 | (synchronized ('*db) 479 | (ensure *db* 480 | (reload-db)) 481 | (check-version) 482 | (lock-db *db*)) 483 | *db*) 484 | 485 | (defun db-loaded? () 486 | (not (null *db*))) 487 | 488 | (defun require-db () 489 | "Load the DB." 490 | (unless (db-loaded?) 491 | (db) 492 | (assert (db-loaded?)))) 493 | 494 | (defun unload-db () 495 | "Clear the DB out of memory in such a way that it can still be 496 | reloaded on demand." 497 | ;; TODO Force a full GC afterwards? 498 | (synchronized ('*db*) 499 | (unlock-db *db*) 500 | (nix *db*))) 501 | 502 | (defun deactivate-db () 503 | "Clear the DB out of memory in such a way that it will not be reloaded on demand." 504 | (synchronized ('*db*) 505 | (unlock-db *db*) 506 | (setq *db* (make-dead-db)))) 507 | 508 | (defun check-version () 509 | "Check that the database version matches the Overlord system version." 510 | (let ((new-version (db-version)) 511 | (old-version (db-version))) 512 | (unless (= new-version old-version) 513 | (cerror "Reload the database" 514 | 'version-mismatch 515 | :new-version new-version 516 | :old-version old-version) 517 | (setq *db* (reload-db))))) 518 | 519 | (defplace db-ref* (key) 520 | (db.ref (db) key) 521 | "Access KEY in the current database.") 522 | 523 | (defgeneric db-protect (x) 524 | (:documentation "Try to avoid writing symbols or package objects into the database. 525 | This allows the database to be reloaded without those packages being 526 | required.") 527 | (:method ((x symbol)) 528 | (eif (memq (symbol-package x) 529 | '#.(list (find-package :keyword) 530 | (find-package :cl) 531 | (find-package :overlord/db))) 532 | x 533 | (let* ((p (symbol-package x))) 534 | (cons (and p (package-name p)) 535 | (symbol-name x))))) 536 | (:method ((x package)) 537 | (cons :package (package-name x))) 538 | (:method (x) x)) 539 | 540 | (defun prop-key (obj prop) 541 | "Convert OBJ and PROP into a single key." 542 | (cons (db-protect obj) 543 | (db-protect prop))) 544 | 545 | (defplace prop-1 (obj prop) 546 | (db.ref (db) (prop-key obj prop)) 547 | "Access the database record keyed by OBJ and PROP.") 548 | 549 | (defun prop (obj prop &optional default) 550 | "Look up a property for an object in the database." 551 | (receive (val val?) (prop-1 obj prop) 552 | (if val? 553 | (values val t) 554 | (values default nil)))) 555 | 556 | (defun (setf prop) (value obj prop &optional default) 557 | "Set an object's property in the database." 558 | (declare (ignore default)) 559 | (setf (prop-1 obj prop) value)) 560 | 561 | (defun has-prop? (obj prop &rest props) 562 | "Test if an object has a property in the database." 563 | (some (op (nth-value 1 (prop-1 obj _))) 564 | (cons prop props))) 565 | 566 | (defun has-props? (obj prop &rest props) 567 | "Check if an object in the database has all of the supplied 568 | properties." 569 | (every (op (nth-value 1 (prop-1 obj _))) 570 | (cons prop props))) 571 | 572 | (defun delete-prop (obj prop) 573 | "Delete a property from OBJ." 574 | (db.del (db) (prop-key obj prop))) 575 | 576 | (defun save-database () 577 | "Save the current database." 578 | (db.sync (db)) 579 | (values)) 580 | 581 | (defun release-database () 582 | (when *db* 583 | (save-database) 584 | (unload-db))) 585 | 586 | (add-exit-hook #'release-database) 587 | 588 | (defun call/saving-database (thunk) 589 | "Call THUNK, saving the database afterwards, unless a save is 590 | already pending." 591 | (if *save-pending* 592 | (funcall thunk) 593 | (let ((*save-pending* t)) 594 | (db) ;Ensure the DB is loaded. 595 | (unwind-protect 596 | (funcall thunk) 597 | (save-database))))) 598 | 599 | (defmacro saving-database (&body body) 600 | "Macro wrapper for `call/saving-database'." 601 | (with-thunk (body) 602 | `(call/saving-database ,body))) 603 | -------------------------------------------------------------------------------- /digest.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/digest 2 | (:use :cl :alexandria :serapeum) 3 | ;; TODO Use something better? 4 | #+sbcl (:import-from :sb-md5 :md5sum-string :md5sum-file) 5 | #-sbcl (:import-from :md5 :md5sum-string :md5sum-file) 6 | (:import-from #:overlord/util 7 | #:byte-array-to-hex-string) 8 | (:export :digest-string :digest-file 9 | :string-digest-string :file-digest-string)) 10 | (in-package :overlord/digest) 11 | 12 | (-> digest-string (string) octet-vector) 13 | (defun digest-string (string) 14 | (values 15 | (md5sum-string string :external-format :utf-8))) 16 | 17 | (-> digest-file (pathname) octet-vector) 18 | (defun digest-file (pathname) 19 | (values (md5sum-file pathname))) 20 | 21 | (-> string-digest-string (string) string) 22 | (defun string-digest-string (string) 23 | (let* ((bytes (digest-string string)) 24 | (hex-string (byte-array-to-hex-string bytes))) 25 | (fmt "md5:~a" hex-string))) 26 | 27 | (-> file-digest-string (pathname) string) 28 | (defun file-digest-string (pathname) 29 | (let* ((bytes (digest-file pathname)) 30 | (hex-string (byte-array-to-hex-string bytes))) 31 | (fmt "md5:~a" hex-string))) 32 | -------------------------------------------------------------------------------- /freeze.lisp: -------------------------------------------------------------------------------- 1 | ;; Freezing the state of the Lisp image. 2 | (defpackage :overlord/freeze 3 | (:use :cl :alexandria :serapeum 4 | :overlord/redo 5 | :overlord/db 6 | :overlord/types 7 | :overlord/message) 8 | (:import-from :overlord/specials 9 | :*suppress-phonies*) 10 | (:import-from :overlord/kernel 11 | :end-meta-kernel) 12 | (:export 13 | :freeze :freeze-policy 14 | :unfreeze 15 | :check-not-frozen 16 | :frozen? 17 | :*before-hard-freeze-hook*)) 18 | (in-package :overlord/freeze) 19 | 20 | (deftype freeze-policy () 21 | '(member t nil :hard)) 22 | 23 | (defparameter *freeze-policy* t) 24 | (declaim (type freeze-policy *freeze-policy*)) 25 | 26 | (defvar *before-hard-freeze-hook* nil) 27 | 28 | (defun freeze-policy () 29 | "Get or set the current freeze policy. 30 | 31 | The freeze policy determines what Overlord does when saving an image. 32 | 33 | A freeze policy of `t' (the default) disables module loading, but can 34 | be reversed with `overlord:unfreeze'. 35 | 36 | A freeze policy of `nil` does nothing. This should only be used for 37 | local development. 38 | 39 | A freeze policy of `:hard' does the same thing as `t', but cannot be 40 | reversed. This should be used when the image is intended to be 41 | distributed." 42 | *freeze-policy*) 43 | 44 | (defun (setf freeze-policy) (value) 45 | (setf *freeze-policy* (assure freeze-policy value))) 46 | 47 | (defvar *frozen* nil 48 | "Is the build system frozen?") 49 | 50 | (defun frozen? () 51 | *frozen*) 52 | 53 | (defparameter *freeze-fmakunbound-hit-list* 54 | '(unfreeze 55 | redo 56 | redo-ifchange 57 | redo-ifcreate 58 | redo-always 59 | redo-stamp 60 | dynamic-require-as)) 61 | 62 | (defun freeze () 63 | ;; NB. You should be able to load an image and save it again. 64 | (unless (frozen?) 65 | (labels ((freeze () 66 | (message "Freezing image...") 67 | (redo) 68 | ;; The DB can still be reloaded, but is not in memory. 69 | (unload-db) 70 | (setf *frozen* t)) 71 | (hard-freeze () 72 | (freeze) 73 | (message "Hard freeze...") 74 | (fmakunbound 'unfreeze) 75 | (run-hooks '*before-hard-freeze-hook*) 76 | ;; The DB will not be reloaded. 77 | (deactivate-db) 78 | (dolist (fn *freeze-fmakunbound-hit-list*) 79 | (fmakunbound fn)))) 80 | (let ((*suppress-phonies* t)) 81 | (ecase-of freeze-policy *freeze-policy* 82 | ((nil)) 83 | ((t) (freeze)) 84 | (:hard (hard-freeze))))))) 85 | 86 | (uiop:register-image-dump-hook 'freeze) 87 | 88 | (defun unfreeze () 89 | (setf *frozen* nil)) 90 | 91 | (defun check-not-frozen () 92 | (when *frozen* 93 | (restart-case 94 | (error* "The build system is frozen.") 95 | (unfreeze () 96 | :report "Unfreeze the build system." 97 | (setf *frozen* nil))))) 98 | -------------------------------------------------------------------------------- /global-state.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/global-state 2 | (:use :cl :serapeum) 3 | (:export 4 | #:define-global-state 5 | #:reset-global-state)) 6 | (in-package :overlord/global-state) 7 | 8 | (defvar *initial-pathname-defaults* 9 | *default-pathname-defaults*) 10 | 11 | (defvar *initial-working-dir* 12 | (uiop:getcwd)) 13 | 14 | (defvar *global-state* 15 | (list 16 | (cons '*default-pathname-defaults* (lambda () *initial-pathname-defaults*)) 17 | (cons '*readtable* (lambda () (copy-readtable nil))) 18 | (cons '*read-base* (constantly 10)) 19 | (cons '*read-default-float-format* (constantly 'double-float)))) 20 | 21 | (defmacro define-global-state (name init &body (&optional docstring)) 22 | `(progn 23 | (pushnew (cons ',name 24 | (lambda () 25 | ,init)) 26 | *global-state* 27 | :key #'car) 28 | (defvar ,name ,init 29 | ,@(unsplice docstring)))) 30 | 31 | (defun reset-global-state () 32 | "Restore Overlord's global state to its value when first loaded. 33 | 34 | This is intended to be the practical equivalent of quitting Lisp and 35 | reloading: it completely resets Overlord's internal state. 36 | 37 | Note that this does not reset *just* Overlord's state. It also resets 38 | a number of Lisp global variables to their default values." 39 | (uiop:chdir *initial-working-dir*) 40 | (loop for (var . init) in *global-state* 41 | collect var 42 | do (setf (symbol-value var) (funcall init)))) 43 | -------------------------------------------------------------------------------- /kernel.lisp: -------------------------------------------------------------------------------- 1 | (uiop:define-package :overlord/kernel 2 | (:use #:cl #:alexandria #:serapeum) 3 | (:import-from #:overlord/message #:message) 4 | (:import-from #:overlord/specials #:use-threads-p) 5 | (:import-from #:lparallel 6 | #:*kernel* 7 | #:make-kernel 8 | #:end-kernel 9 | #:pmap 10 | #:task-handler-bind 11 | #:invoke-transfer-error) 12 | (:import-from #:uiop 13 | #:register-image-dump-hook) 14 | (:export 15 | #:with-meta-kernel 16 | #:end-meta-kernel 17 | #:nproc)) 18 | (in-package :overlord/kernel) 19 | 20 | (defconst thread-count-cap 20) 21 | 22 | (defun nproc () 23 | (assure (integer 1 *) 24 | (count-cpus :online nil))) 25 | 26 | (def nproc 27 | (nproc)) 28 | 29 | (def meta-kernel-size 30 | (min thread-count-cap 31 | (* 2 nproc))) 32 | 33 | (defvar *meta-kernel* nil 34 | "Lparallel kernel for fetching target metadata.") 35 | 36 | (defun call/meta-kernel (thunk) 37 | (if (use-threads-p) 38 | (let ((*kernel* (ensure-meta-kernel))) 39 | (task-handler-bind ((error #'invoke-transfer-error)) 40 | (funcall thunk))) 41 | (funcall thunk))) 42 | 43 | (defmacro with-meta-kernel ((&key) &body body) 44 | (with-thunk (body) 45 | `(call/meta-kernel ,body))) 46 | 47 | (defun ensure-meta-kernel () 48 | (start-meta-kernel) 49 | *meta-kernel*) 50 | 51 | (defun start-meta-kernel () 52 | (unless *meta-kernel* 53 | (synchronized ('*meta-kernel*) 54 | (unless *meta-kernel* 55 | (message "Initializing metadata thread pool for session") 56 | (setf *meta-kernel* 57 | (make-kernel meta-kernel-size 58 | :name "Overlord metadata fetcher")))))) 59 | 60 | (defun end-meta-kernel () 61 | "Terminate the Overlord kernel." 62 | (when *meta-kernel* 63 | (synchronized ('*meta-kernel*) 64 | (when-let (kernel *meta-kernel*) 65 | (setf *meta-kernel* nil) 66 | (message "Terminating Overlord metadata thread pool") 67 | (let ((*kernel* kernel)) 68 | (end-kernel :wait t)))))) 69 | 70 | (register-image-dump-hook 'end-meta-kernel) 71 | -------------------------------------------------------------------------------- /makespan.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/makespan 2 | (:use :cl :alexandria :serapeum) 3 | (:export :minimize-makespan 4 | :optimal-machine-count)) 5 | (in-package :overlord/makespan) 6 | 7 | ;;; Minimize the makespan of a set of tasks. 8 | 9 | ;;; Bear in mind that minimizing a makespan is an NP-hard problem. 10 | ;;; Fortunately, there is an algorithm, the LPT algorithm, that gives 11 | ;;; theoretically good results, and even better results in practice. 12 | 13 | ;;; Our terminology differs slightly from that usually used in 14 | ;;; discussions of scheduling algorithms; what are usually called 15 | ;;; jobs, we will call tasks, to avoid confusion with the use of "job" 16 | ;;; in the rest of Overlord. 17 | 18 | (defstruct machine 19 | (total-time 0 :type (integer 0 *)) 20 | (task-queue (queue) :type queue)) 21 | 22 | (defconstructor task 23 | (task t) 24 | (time (integer 0 *))) 25 | 26 | (defun machine-add-task (machine task) 27 | (incf (machine-total-time machine) 28 | (task-time task)) 29 | (enq task (machine-task-queue machine)) 30 | machine) 31 | 32 | (defun machine-tasks (machine) 33 | (qlist (machine-task-queue machine))) 34 | 35 | (defun minimize-makespan (machine-count targets build-times) 36 | "Given MACHINE-COUNT, a sequence of TARGETS, and a sequence of 37 | BUILD-TIMES for each target, distribute TARGETS into batches, at most 38 | one batch per machine (but possibly less), in such a way as to 39 | minimize their makespan -- the time until the last machine is done 40 | with the last task." 41 | (assert (length= targets build-times)) 42 | (let* ((build-times 43 | ;; Add 1 to every build time so we get reasonable results 44 | ;; for targets with a build time of 0, which can happen 45 | ;; either because the target is too cheap to meter, or 46 | ;; because it hasn't been run yet. 47 | (map 'vector #'1+ build-times)) 48 | (tasks (map 'vector #'task targets build-times))) 49 | (lpt-schedule machine-count tasks))) 50 | 51 | (defun optimal-machine-count (build-times) 52 | (if (emptyp build-times) 0 53 | (let ((max (extremum build-times #'>))) 54 | (if (zerop max) (length build-times) 55 | (let ((sum (reduce #'+ build-times))) 56 | (ceiling (/ sum max))))))) 57 | 58 | (defun lpt-schedule (machine-count tasks) 59 | "Implement the Longest Processing Time algorithm. 60 | MACHINE-COUNT should be an integer. 61 | 62 | Times should be given as integers." 63 | (check-type machine-count (integer 1 *)) 64 | (let ((tasks (sort-new tasks #'> :key #'task-time)) 65 | (heap (make-heap :size machine-count 66 | :test #'< 67 | :key #'machine-total-time))) 68 | (loop repeat machine-count do 69 | (heap-insert heap (make-machine))) 70 | (do-each (task tasks) 71 | (let* ((first-finished (heap-extract-maximum heap)) 72 | (machine (machine-add-task first-finished task))) 73 | (heap-insert heap machine))) 74 | (let* ((machines (reverse (heap-extract-all heap))) 75 | (batches (map 'list #'machine-tasks machines))) 76 | (loop for batch in batches 77 | collect (map 'list #'task-task batch))))) 78 | -------------------------------------------------------------------------------- /message.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/message 2 | (:use :cl :alexandria :serapeum 3 | :overlord/global-state) 4 | (:import-from :overlord/types :error*) 5 | (:import-from :cl-ppcre :all-matches-as-strings) 6 | (:shadowing-import-from :cl-ppcre :scan) 7 | (:export 8 | :overlord-message 9 | :message 10 | :*message-stream*)) 11 | (in-package :overlord/message) 12 | 13 | (define-global-state *message-stream* 14 | (make-synonym-stream '*error-output*) 15 | "The stream printed to by the default message handler.") 16 | 17 | (defun message (control &rest args) 18 | (let* ((stream *message-stream*) 19 | (control 20 | (if (and (stringp control) 21 | (string$= "." control)) 22 | (string-right-trim "." control) 23 | control))) 24 | (prog1 (format stream "~&[overlord] ~?~%" control args) 25 | (force-output stream)))) 26 | 27 | (define-compiler-macro message (&whole call format-control &rest format-arguments) 28 | (if (not (stringp format-control)) call 29 | (progn 30 | (sanity-check-message-args format-control format-arguments) 31 | (let ((format-control (string-right-trim "." format-control))) 32 | `(message (formatter ,format-control) ,@format-arguments))))) 33 | 34 | (defun sanity-check-message-args (format-control format-arguments) 35 | "Do some basic sanity-checking with format-control and format-arguments." 36 | (when (stringp format-control) 37 | (when-let (required (guess-arg-count format-control)) 38 | (let ((provided (length format-arguments))) 39 | (unless (= required provided) 40 | (error* "Message format string requires ~d argument~:p, but ~d ~:*~[were~;was~:;were~] provided." 41 | required 42 | provided)))))) 43 | 44 | (defun guess-arg-count (format-string) 45 | "When possible, Guess the number of arguments required by FORMAT-STRING." 46 | (let ((directives (extract-directives format-string))) 47 | (when (every (op (scan "~[a-zA-Z]" _)) directives) 48 | (length directives)))) 49 | 50 | (defun extract-directives (format-string) 51 | (all-matches-as-strings "(~.)" format-string)) 52 | -------------------------------------------------------------------------------- /net.lisp: -------------------------------------------------------------------------------- 1 | ;;; net.lisp -- update a downloaded file 2 | (defpackage #:overlord/net 3 | (:use #:cl #:alexandria #:serapeum 4 | #:overlord/types 5 | #:overlord/global-state) 6 | (:import-from #:overlord/util 7 | #:file-mtime 8 | #:write-file-if-changed) 9 | (:import-from #:cl-strftime #:format-time) 10 | (:import-from #:drakma #:http-request) 11 | (:import-from #:overlord/base #:ensure-absolute) 12 | (:import-from #:serapeum #:make-octet-vector) 13 | (:import-from #:overlord/message 14 | #:message) 15 | (:export #:update-file-from-url 16 | #:ensure-file-from-url 17 | #:go-offline 18 | #:go-online 19 | #:*connection-timeout* 20 | #:online-only)) 21 | 22 | ;;; This is an (optional) facility for updating a file from a URL. 23 | ;;; When you call (update-file-from-url FILE URL), we make a request 24 | ;;; to URL with an If-Modified-Since header derived from FILE's mtime. 25 | ;;; If the resource at the URL is newer than FILE, then we download 26 | ;;; the resource and replace FILE with it. 27 | 28 | (in-package #:overlord/net) 29 | 30 | (define-global-state *offline* nil 31 | "Are we offline?") 32 | (declaim (type boolean *offline*)) 33 | 34 | (defparameter *connection-timeout* 5) 35 | 36 | (defun call/online (thunk &key error) 37 | (if *offline* 38 | (if error 39 | (restart-case 40 | (error* "Can't do that offline.") 41 | (go-online () 42 | :report "Go back online." 43 | (go-online) 44 | (call/online thunk))) 45 | nil) 46 | (restart-case 47 | (funcall thunk) 48 | (go-offline () 49 | :report "Continue as if offline." 50 | (go-offline))))) 51 | 52 | (defmacro online-only ((&key error) &body body) 53 | (with-thunk (body) 54 | `(call/online ,body :error ,error))) 55 | 56 | (defun http-request/binary (url &rest args) 57 | (apply #'http-request url 58 | :force-binary t 59 | :connection-timeout *connection-timeout* 60 | args)) 61 | 62 | (defun update-file-from-url (file url) 63 | (lret ((file (ensure-absolute file))) 64 | (if (not (uiop:file-exists-p file)) 65 | (if *offline* 66 | (error* "Offline: cannot retrieve ~a" file) 67 | (multiple-value-bind (data status) (http-request/binary url) 68 | (when (= status 200) 69 | (write-byte-vector-into-file data file)))) 70 | (if *offline* 71 | (message "File ~a exists, not updating because offline." 72 | file) 73 | (online-only () 74 | (let ((fwd (file-mtime file))) 75 | (multiple-value-bind (data status) 76 | (http-request/binary 77 | url 78 | :additional-headers 79 | `((:if-modified-since . ,(format-mtime fwd)))) 80 | (if (= status 200) 81 | (progn 82 | (message "File ~a was changed remotely." file) 83 | (write-file-if-changed data file)) 84 | (message "File ~a was not modified (code ~a)." 85 | file 86 | status))))))))) 87 | 88 | (defun ensure-file-from-url (file url) 89 | "Unlike `update-file-from-url' this does not preserve URL's 90 | timestamp." 91 | (lret ((file (ensure-absolute file))) 92 | (unless (uiop:file-exists-p file) 93 | (online-only () 94 | (multiple-value-bind (body status) (http-request/binary url) 95 | (if (= status 200) 96 | (write-byte-vector-into-file body file) 97 | (error* "Could not fetch ~a: code ~a" url status))))))) 98 | 99 | (defun go-offline () 100 | (setf *offline* t)) 101 | 102 | (defun go-online () 103 | (setf *offline* nil)) 104 | 105 | (defun format-mtime (mtime) 106 | (format-time nil :http mtime)) 107 | 108 | -------------------------------------------------------------------------------- /oracle.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/oracle 2 | (:use :cl :alexandria :serapeum :trivia 3 | :overlord/target-protocol) 4 | (:shadowing-import-from :trivia :@) 5 | (:import-from :named-readtables 6 | :readtable-name) 7 | (:import-from :overlord/util 8 | :class-name-of 9 | :byte-array-to-hex-string) 10 | (:import-from :overlord/redo 11 | :redo-ifchange 12 | :redo-ifcreate) 13 | (:import-from :overlord/types 14 | :absolute-pathname 15 | :delayed-symbol 16 | :delayed-symbol= 17 | :force-symbol 18 | :delay-symbol 19 | :overlord-error 20 | :wild-pathname) 21 | (:import-from :overlord/digest 22 | :string-digest-string) 23 | (:import-from :overlord/asdf 24 | :asdf-system-version) 25 | (:import-from :overlord/util 26 | :version-major-version) 27 | (:import-from :cmd :$cmd) 28 | (:import-from :fset) 29 | (:import-from #:cl-strftime 30 | #:format-time) 31 | (:import-from #:local-time 32 | #:now) 33 | (:import-from #:cl-murmurhash 34 | #:murmurhash) 35 | (:export 36 | :oracle 37 | :oracle-question 38 | :oracle-answer 39 | :var-oracle 40 | :env-oracle 41 | :system-version-oracle 42 | :feature-oracle 43 | :dist-version-oracle 44 | :function-oracle 45 | :daily-oracle 46 | :--version 47 | :glob-target)) 48 | (in-package :overlord/oracle) 49 | 50 | ;;; TODO Would it be worthwhile to provide oracles for optimization 51 | ;;; qualities (speed, debug, safety)? You could get them through 52 | ;;; introspect-environment. 53 | 54 | (deftype oracle-answer () 55 | '(or 56 | number 57 | ;; NB boolean is a subtype of symbol. 58 | symbol 59 | string)) 60 | 61 | (defgeneric oracle-answer (oracle)) 62 | 63 | (defclass oracle () 64 | ((question :initarg :question 65 | :reader oracle-question)) 66 | (:documentation "Oracles let you depend on aspects of the Lisp or OS 67 | environment. 68 | 69 | When you depend on an oracle, Overlord remembers the answer the oracle 70 | gave at the time of the dependency \(or the lack of an answer, if the 71 | oracle was unbound). If that answer changes, then any targets that 72 | depend on the oracle are considered out of date.")) 73 | 74 | (defmethods oracle (self question) 75 | (:method make-load-form (self &optional env) 76 | (make-load-form-saving-slots self 77 | :slot-names '(question) 78 | :environment env)) 79 | (:method print-object (self stream) 80 | (format stream "~a~s" 81 | (read-eval-prefix self stream) 82 | `(make-instance ',(class-name-of self) :question ,question))) 83 | 84 | (:method fset:compare (self (other oracle)) 85 | (fset:compare-slots self other 86 | #'class-name-of 87 | #'oracle-question)) 88 | (:method target= (self (other oracle)) 89 | (eql :equal (fset:compare self other))) 90 | 91 | 92 | (:method hash-target (self) 93 | (sxhash (make-load-form self))) 94 | (:method oracle-answer :around (self) 95 | (assure oracle-answer 96 | (call-next-method))) 97 | (:method target-stamp (self) 98 | (let ((answer (oracle-answer self))) 99 | (if (stringp answer) 100 | (string-digest-string answer) 101 | (prin1-to-string answer)))) 102 | (:method target-node-label (self) 103 | (fmt "oracle for ~a" question))) 104 | 105 | 106 | ;;; Var oracles. 107 | 108 | (defclass var-oracle (oracle) 109 | ((question :reader var-oracle.var 110 | :initarg :var 111 | :type delayed-symbol) 112 | (sym :type symbol 113 | :documentation "Cache for the resolved symbol.")) 114 | (:default-initargs 115 | :var (required-argument :var)) 116 | (:documentation "Oracle that wraps a special variable. 117 | 118 | Oracles for Lisp variables are intended to allow a target to 119 | record the fact that it depends on some aspect of the compile time 120 | or read time environment (e.g. `*read-base*') and should be 121 | considered out of date if that changes.")) 122 | 123 | (defmethods var-oracle (self (var question) sym) 124 | (:method initialize-instance :after (self &key var) 125 | (setf var (delay-symbol var))) 126 | ;; Cache the symbol. 127 | (:method slot-unbound ((class t) self (slot-name (eql 'sym))) 128 | (setf sym (force-symbol var))) 129 | (:method oracle-answer (self) 130 | (symbol-value sym)) 131 | (:method target-exists? (self) 132 | (boundp sym)) 133 | (:method target= (self (other var-oracle)) 134 | (handler-case 135 | (eql sym (slot-value other 'sym)) 136 | (overlord-error () 137 | ;; The symbols haven't been, or can't be, resolved. 138 | (delayed-symbol= var (var-oracle.var other)))))) 139 | 140 | (defclass cl-var-oracle (oracle) 141 | ((question :type symbol 142 | :initarg :var)) 143 | (:default-initargs 144 | :var (required-argument :var)) 145 | (:documentation 146 | "Oracle that wraps a special variable in the CL package.")) 147 | 148 | (defun cl-sym? (sym) 149 | (eql (symbol-package sym) 150 | (find-package :cl))) 151 | 152 | (defmethods cl-var-oracle (self (var question)) 153 | (:method initialize-instance :after (self &key) 154 | (assert (cl-sym? var))) 155 | (:method oracle-answer (self) 156 | (symbol-value var)) 157 | (:method target-exists? (self) 158 | (boundp var)) 159 | (:method target= (self (other cl-var-oracle)) 160 | (eql var (oracle-question other)))) 161 | 162 | (defclass fixed-question-oracle (oracle) 163 | ((question :reader fixed-question-oracle.name)) 164 | (:documentation 165 | "Oracle that extracts a name from a value instead of recording the 166 | value directly. The question is also the answer.")) 167 | 168 | (defmethods fixed-question-oracle (self (name question)) 169 | (:method oracle-answer (self) 170 | name) 171 | (:method target-exists? (self) 172 | t) 173 | (:method target= (self (other fixed-question-oracle)) 174 | (eql name (oracle-question other)))) 175 | 176 | (defclass package-oracle (fixed-question-oracle) 177 | ((question :type string 178 | :reader package-oracle.name 179 | :initform (package-name *package*))) 180 | (:documentation "Oracle that wraps the current package.")) 181 | 182 | (defmethods package-oracle (self (name question)) 183 | (:method target= (self (other package-oracle)) 184 | (string= name (package-oracle.name other)))) 185 | 186 | (defclass readtable-oracle (fixed-question-oracle) 187 | ((question :type delayed-symbol 188 | :initform (delay-symbol (readtable-name *readtable*)))) 189 | (:documentation "Oracle that wraps the current readtable. 190 | 191 | A name is extracted using `named-readtable:readtable-name'.")) 192 | 193 | (defmethods readtable-oracle (self (name question)) 194 | (:method target= (self (other readtable-oracle)) 195 | (delayed-symbol= name (fixed-question-oracle.name other)))) 196 | 197 | (defun var-oracle (var) 198 | (check-type var symbol) 199 | (cond ((eql var '*readtable*) 200 | (make 'readtable-oracle)) 201 | ((eql var '*package*) 202 | (make 'package-oracle)) 203 | ((cl-sym? var) 204 | (make 'cl-var-oracle :var var)) 205 | (t (make 'var-oracle :var var)))) 206 | 207 | 208 | ;;; Environment oracles. 209 | 210 | (defclass env-oracle (oracle) 211 | ((question :initarg :name 212 | :type string 213 | :reader env-oracle.name)) 214 | (:default-initargs 215 | :name (required-argument :name)) 216 | (:documentation "Oracle that wraps an environment variable.")) 217 | 218 | (defmethods env-oracle (self (name question)) 219 | (:method oracle-answer (self) 220 | (uiop:getenv name)) 221 | (:method target-stamp (self) 222 | (string-digest-string (oracle-answer self))) 223 | (:method target-exists? (self) 224 | (uiop:getenvp name)) 225 | (:method target= (self (other env-oracle)) 226 | (equal name (env-oracle.name other)))) 227 | 228 | (defun env-oracle (name) 229 | (make 'env-oracle 230 | :name (assure string name))) 231 | 232 | 233 | ;;; System version oracles. 234 | 235 | (defclass system-version-oracle (oracle) 236 | ((question :initarg :name 237 | :reader system-version-oracle.system-name 238 | :type string)) 239 | (:documentation "Using a system version oracle, you can depend on 240 | the major version of an ASDF system. 241 | 242 | Note that if the system is not known to ASDF, then the version 243 | recorded is simply nil.")) 244 | 245 | (defmethods system-version-oracle (self (name question)) 246 | (:method target= (self (other system-version-oracle)) 247 | (let ((other-name 248 | (system-version-oracle.system-name other))) 249 | (string-equal name other-name))) 250 | (:method target-exists? (self) 251 | t) 252 | (:method oracle-answer (self) 253 | (version-major-version (asdf-system-version name))) 254 | (:method target-node-label (self) 255 | (fmt "system major version ~a" name))) 256 | 257 | (defun system-version-oracle (name) 258 | (make 'system-version-oracle :name (string-downcase name))) 259 | 260 | 261 | ;;; Dist version oracles. 262 | 263 | ;;; Depend on the current version of a Quicklisp dist. 264 | 265 | (defconst quicklisp "quicklisp") 266 | 267 | (defun dist-exists? (dist) 268 | (and (find-package :ql-dist) 269 | (uiop:symbol-call :ql-dist :find-dist 270 | (assure string dist)))) 271 | 272 | (defun ql-dist-version (&optional (dist-name quicklisp)) 273 | (when-let (dist (dist-exists? dist-name)) 274 | (uiop:symbol-call :ql-dist :version dist))) 275 | 276 | (defclass dist-version-oracle (oracle) 277 | ((question :initarg :name 278 | :reader dist-version-oracle.name 279 | :type string)) 280 | (:documentation "An oracle that reports the current version of a 281 | Quicklisp dist. 282 | 283 | By default this is the Quicklisp dist itself.") 284 | (:default-initargs 285 | :name quicklisp)) 286 | 287 | (defmethods dist-version-oracle (self (name question)) 288 | (:method target-exists? (self) 289 | (dist-exists? name)) 290 | (:method oracle-answer (self) 291 | (ql-dist-version name)) 292 | (:method target= (self (other dist-version-oracle)) 293 | (equal name (dist-version-oracle.name other)))) 294 | 295 | (defun dist-version-oracle (&optional (dist-name quicklisp)) 296 | (make 'dist-version-oracle 297 | :name (assure string dist-name))) 298 | 299 | 300 | ;;;; Feature oracles. 301 | 302 | ;;; TODO We could do automatic translation (along the lines of 303 | ;;; trivial-features) to ensure that feature dependencies are 304 | ;;; portable? 305 | 306 | (defclass feature-oracle (oracle) 307 | ((question :initarg :feature 308 | :type keyword 309 | :reader feature-oracle.feature)) 310 | (:documentation "An oracle that wraps whether a particular keyword 311 | is present in `*features*'.")) 312 | 313 | (defun feature-oracle (feature) 314 | (make 'feature-oracle 315 | :feature (assure keyword feature))) 316 | 317 | (defmethods feature-oracle (self (feature question)) 318 | (:method target-exists? (self) 319 | (featurep feature)) 320 | (:method oracle-answer (self) 321 | t) 322 | (:method target= (self (other feature-oracle)) 323 | (eql feature (feature-oracle.feature other)))) 324 | 325 | 326 | ;;; Date oracles. 327 | 328 | ;;; For targets that should only be built once a day. 329 | 330 | (defun todays-date-string () 331 | (format-time nil "%F" (now))) 332 | 333 | (defun daily-oracle () 334 | "Depend on today's date. 335 | This is for targets that should be no more than one a day." 336 | (function-oracle 'todays-date-string)) 337 | 338 | 339 | ;;; Version oracles. 340 | 341 | (defun get-version (command) 342 | ($cmd command "--version")) 343 | 344 | (defun --version (command) 345 | "An oracle that monitors the version of COMMAND (by calling it with 346 | an argument of `--version'." 347 | (function-oracle 'get-version command)) 348 | 349 | 350 | ;;; Glob oracles. 351 | 352 | (defun wildcard-hash (wildcard) 353 | (declare (type (and absolute-pathname wild-pathname) wildcard)) 354 | (let* ((files (directory wildcard)) 355 | (files (map 'vector #'namestring files)) 356 | (files (sort files #'string<)) 357 | (hash (murmurhash files))) 358 | (print (integer-length hash)) 359 | (fmt "murmurhash3:~(~x~)" hash))) 360 | 361 | (defun glob-target (wildcard) 362 | (check-type wildcard (and absolute-pathname wild-pathname)) 363 | (function-oracle 'wildcard-hash wildcard)) 364 | 365 | 366 | ;;; Function oracles. 367 | 368 | ;;; For easy extension. 369 | (defclass function-oracle (oracle) 370 | ((question :initarg :function 371 | :type delayed-symbol 372 | :reader function-oracle.delayed-symbol) 373 | (args 374 | :initarg :args 375 | :type list 376 | :reader function-oracle.args)) 377 | (:documentation "An oracle for a user-supplied function. 378 | 379 | The function must be supplied as a symbol.") 380 | (:default-initargs 381 | :args nil)) 382 | 383 | (defmethods function-oracle (self (fn question) args) 384 | (:method target-exists? (self) 385 | (fboundp 386 | (ignoring overlord-error 387 | (force-symbol fn)))) 388 | (:method oracle-answer (self) 389 | (apply (force-symbol fn) args)) 390 | (:method print-object (self stream) 391 | (format stream "~a~s" 392 | (read-eval-prefix self stream) 393 | `(make-instance 'function-oracle 394 | :function ,fn 395 | :args '(,@args))))) 396 | 397 | (defun function-oracle (function-name &rest args) 398 | (check-type function-name symbol) 399 | (make 'function-oracle 400 | :function (delay-symbol function-name) 401 | :args args)) 402 | -------------------------------------------------------------------------------- /overlord.asd: -------------------------------------------------------------------------------- 1 | ;;;; overlord.asd 2 | (in-package :asdf) 3 | 4 | (assert (uiop:version< "3.1" (asdf:asdf-version))) 5 | 6 | (defsystem "overlord" 7 | :description "Experimental build system." 8 | :author "Paul M. Rodriguez " 9 | :license "MIT" 10 | :version (:read-file-form "version.sexp") 11 | :class :package-inferred-system 12 | :depends-on ("overlord/all") 13 | :in-order-to ((test-op (test-op "overlord/tests"))) 14 | :perform (test-op (o c) (symbol-call :overlord/tests :run-overlord-tests))) 15 | 16 | (register-system-packages "lparallel" '(:lparallel.queue :lparallel.kernel-util)) 17 | -------------------------------------------------------------------------------- /project-system.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/project-system 2 | (:use :cl :alexandria :serapeum) 3 | (:import-from :overlord/types :error*) 4 | (:import-from :overlord/target :build) 5 | (:import-from :quickproject :make-project) 6 | (:import-from :uiop :ensure-directory-pathname) 7 | (:documentation "Very basic, experimental ASDF extension. Looks for 8 | a package with the same name as the system and a symbol named `all' in 9 | that package, and builds that. 10 | 11 | Use `asdf:make' to get the desired behavior.") 12 | (:export :overlord-project-system :start-project)) 13 | (in-package :overlord/project-system) 14 | 15 | (defclass overlord-project-system (asdf:system) 16 | ((target-name 17 | :initarg :target-name 18 | :initform (string 'all) 19 | :reader project-system-target-name))) 20 | 21 | (defun build-default-system-target (system) 22 | (let* ((system-name 23 | (string-upcase 24 | (asdf:component-name system))) 25 | (target-name 26 | (string-upcase 27 | (project-system-target-name system))) 28 | (package 29 | (or (find-package system-name) 30 | (error* "No such package as ~a" system-name))) 31 | (symbol 32 | (or (find-symbol (string-upcase target-name) 33 | package) 34 | (error* "No such symbol as ~a in ~a" 35 | 'all package)))) 36 | (build symbol))) 37 | 38 | (defmethod asdf:operate :after ((op asdf-utilities:build-op) 39 | (system overlord-project-system) 40 | &key) 41 | (build-default-system-target system)) 42 | 43 | (def template-directory 44 | (asdf:system-relative-pathname :overlord #p"template/")) 45 | 46 | (defun start-project (directory 47 | &rest keys 48 | &key (target-name "all") depends-on 49 | &allow-other-keys) 50 | "Initialize a new Overlord project. 51 | If DIRECTORY is relative, it is created as a subdirectory of 52 | " 53 | (apply #'make-project 54 | (path-join #p"~/common-lisp/" (ensure-directory-pathname directory)) 55 | :template-parameters (list :target (string target-name)) 56 | :template-directory template-directory 57 | :include-copyright nil 58 | :depends-on (cons "overlord" depends-on) 59 | (remove-from-plist keys :target-name))) 60 | -------------------------------------------------------------------------------- /redo.lisp: -------------------------------------------------------------------------------- 1 | ;;; High-level build system implementation. This package uses the 2 | ;;; protocol exported by overlord/target-protocol. 3 | 4 | (defpackage :overlord/redo 5 | (:use #:cl #:alexandria #:serapeum 6 | #:overlord/specials 7 | #:overlord/target-protocol 8 | #:overlord/target-table 9 | #:overlord/build-env) 10 | (:import-from #:overlord/kernel 11 | #:with-meta-kernel 12 | #:nproc) 13 | (:import-from #:lparallel 14 | #:make-channel 15 | #:receive-result 16 | #:psome #:pmap 17 | #:task-handler-bind 18 | #:invoke-transfer-error 19 | #:submit-task) 20 | (:import-from #:overlord/types 21 | #:overlord-error 22 | #:overlord-error-target) 23 | (:import-from #:overlord/db 24 | #:*db*) 25 | (:import-from #:overlord/stamp 26 | #:stamp-satisfies-p) 27 | (:import-from #:overlord/makespan 28 | #:minimize-makespan 29 | #:optimal-machine-count) 30 | (:import-from #:local-time 31 | #:now) 32 | (:import-from #:overlord/util 33 | #:timestamp-diff) 34 | (:nicknames :redo) 35 | (:export 36 | #:recursive-dependency 37 | #:missing-script 38 | #:building? 39 | #:redo 40 | #:redo-all 41 | #:redo-ifchange 42 | #:redo-ifchange-all 43 | #:redo-ifcreate 44 | #:redo-ifcreate-all 45 | #:redo-always 46 | #:*parents* 47 | #:target-tree)) 48 | (in-package #:overlord/redo) 49 | 50 | ;;; NB This file is only concerned with the logic of the build system. 51 | ;;; It is not concerned with what targets are, what timestamps are, or 52 | ;;; so forth. 53 | 54 | (defcondition target-error (overlord-error) 55 | ((target :initarg :target 56 | :reader overlord-error-target))) 57 | 58 | (defcondition recursive-dependency (target-error) 59 | () 60 | (:report (lambda (c s) 61 | (format s "Recursive dependency: ~a depends on itself" 62 | (overlord-error-target c))))) 63 | 64 | (defcondition missing-script (target-error) 65 | () 66 | (:report (lambda (c s) 67 | (format s "No script found for target ~a." 68 | (overlord-error-target c))))) 69 | 70 | (defcondition non-existent-exists (target-error) 71 | () 72 | (:report (lambda (c s) 73 | (format s "Non-existent prerequisite ~a exists." 74 | (overlord-error-target c))))) 75 | 76 | (defvar *parents* '() 77 | "The chain of parents being built.") 78 | (register-worker-special '*parents*) 79 | 80 | (defun building? () 81 | "Return T if anything is being built." 82 | (true *parents*)) 83 | 84 | (defun target? (target) 85 | "Is TARGET actually a target (not a source file)?" 86 | (or 87 | ;; (not (target-exists? target)) 88 | ;; (target-in-db? target) 89 | 90 | ;; NB This is a deviation from the Redo model. We don't want to 91 | ;; depend on the database to tell what is or is not a target, 92 | ;; because the database is cleared every time Overlord, or the 93 | ;; underlying Lisp, is upgraded. Instead, what makes something a 94 | ;; target is that it has a build script. (This idea comes from 95 | ;; Gup). However (see `out-of-date?' below) a target is still 96 | ;; considered out of date if it has no presence in the DB. 97 | (target-has-build-script? target))) 98 | 99 | (defun redo (&rest targets) 100 | "Unconditionally build each target in TARGETS." 101 | (unless (emptyp targets) 102 | (redo-all targets))) 103 | 104 | (defun target-build-script-target (target) 105 | (build-script-target 106 | (target-build-script target))) 107 | 108 | (defun target-has-build-script? (target) 109 | (target-exists? (target-build-script-target target))) 110 | 111 | (defun redo-target (target) 112 | "Unconditionally build TARGET." 113 | (let ((target (resolve-target target)) 114 | start end) 115 | (ensure (cached-stamp target) 116 | (with-target-locked (target) 117 | (when (member target *parents* :test #'target=) 118 | (error 'recursive-dependency 119 | :target target)) 120 | (when (target? target) 121 | (clear-temp-prereqs target) 122 | (clear-temp-prereqsne target) 123 | (let ((build-script (resolve-build-script target))) 124 | (unwind-protect 125 | (let ((*parents* (cons target *parents*))) 126 | (setf start (now)) 127 | (run-script build-script) 128 | (setf end (now))) 129 | (save-temp-prereqs target) 130 | (save-temp-prereqsne target)) 131 | (setf (target-build-time target) 132 | (timestamp-diff end start)))) 133 | (target-stamp target))))) 134 | 135 | (defun walk-targets (fn targets &key (jobs nproc)) 136 | "Call FN on each targets in TARGETS, in some order, and possibly in 137 | parallel." 138 | (check-type fn function) 139 | (check-type jobs (integer 1 *)) 140 | (assert (build-env-bound?)) 141 | (labels ((walk-targets/serial (fn targets) 142 | ;; Send locked targets to the back of the line. 143 | (let ((skipped nil)) 144 | (loop while targets do 145 | (do-each (target targets) 146 | (if (target-locked-p target) 147 | (push target skipped) 148 | (funcall fn target))) 149 | (nreversef skipped) 150 | (shiftf targets skipped nil)))) 151 | (try-get-tokens (build-times) 152 | (let ((ideal (optimal-machine-count build-times))) 153 | (loop for n below (min jobs 154 | ideal 155 | (length build-times)) 156 | for token = (ask-for-token*) 157 | while token 158 | collect token))) 159 | (walk-targets/parallel (fn targets) 160 | (let* ((build-times 161 | (pmap* 'list #'target-build-time targets)) 162 | (tokens (try-get-tokens build-times))) 163 | (if (null tokens) 164 | (walk-targets/serial fn targets) 165 | (let* ((batches 166 | (minimize-makespan 167 | ;; Remember we are also using the current 168 | ;; thread. 169 | (1+ (length tokens)) 170 | targets 171 | build-times)) 172 | (channels 173 | (loop repeat (length tokens) 174 | collect (make-channel)))) 175 | (assert (= (1- (length batches)) 176 | (length tokens) 177 | (length channels))) 178 | (loop for batch in batches 179 | for token in tokens 180 | for ch in channels 181 | do (submit-task ch 182 | ;; Watch out, loop can 183 | ;; mutate its variables. 184 | (let ((batch batch) 185 | (token token)) 186 | (lambda () 187 | (unwind-protect 188 | (walk-targets/serial fn batch) 189 | (return-token* token)))))) 190 | ;; NB Because there is one fewer token than there 191 | ;; are batches, when this loop exits the last 192 | ;; batch is left to be handled by the current 193 | ;; thread. 194 | (walk-targets/serial fn (lastcar batches)) 195 | (map nil #'receive-result channels)))))) 196 | ;; We wrap the FN regardless of whether we are using parallelism or 197 | ;; not, to prevent reliance on side-effects. 198 | (let ((fn (wrap-worker-specials fn)) 199 | (targets (reshuffle targets))) 200 | (if (and (use-threads-p) 201 | ;; Don't bother with parallelism if there is only one 202 | ;; target to build. 203 | (length> targets 1)) 204 | (walk-targets/parallel fn targets) 205 | (walk-targets/serial fn targets))))) 206 | 207 | (defun redo-all (targets &key (jobs nproc) 208 | debug) 209 | "Unconditionally build each target in TARGETS." 210 | (unless (emptyp targets) 211 | (with-build-env (:jobs jobs :debug debug) 212 | (walk-targets #'redo-target targets :jobs jobs)))) 213 | 214 | (defun resolve-build-script (target) 215 | "Find a build script for TARGET, and depend on it. 216 | If there is no script for TARGET, signal an error." 217 | ;; TODO What directory should be current? Or should the script take care of that? 218 | (let* ((target (resolve-target target)) 219 | (script (target-build-script target)) 220 | (script-target (build-script-target script))) 221 | (if (target-exists? script-target) 222 | (let ((*parents* (cons target *parents*))) 223 | (redo-ifchange script-target) 224 | script) 225 | (progn 226 | (cerror "Retry" 227 | 'missing-script 228 | :target target) 229 | (resolve-build-script target))))) 230 | 231 | (defun prereq-changed? (saved-prereq) 232 | "Take SAVED-PREREQ, which has slots for a target and its last stamp, 233 | and return T if the stamp has changed." 234 | (let* ((req (saved-prereq-target saved-prereq)) 235 | (old-stamp (saved-prereq-stamp saved-prereq)) 236 | (new-stamp (target-stamp/cache req))) 237 | (not (stamp-satisfies-p new-stamp old-stamp)))) 238 | 239 | (defun psome* (fn seq) 240 | "Like `some', but possibly parallel." 241 | (let ((fn (wrap-worker-specials fn))) 242 | (if (use-threads-p) 243 | (with-meta-kernel () 244 | (psome fn seq)) 245 | (some fn seq)))) 246 | 247 | (defun pmap* (type fn seq) 248 | "Like `map', but possibly parallel." 249 | (let ((fn (wrap-worker-specials fn))) 250 | (if (use-threads-p) 251 | (with-meta-kernel () 252 | (pmap type fn seq)) 253 | (map type fn seq)))) 254 | 255 | (defun out-of-date? (target) 256 | "Return T if TARGET needs rebuilding. 257 | Note that this rebuilds any previously saved dependencies of TARGET 258 | that are themselves out of date." 259 | (mvlet* ((prereqsne (target-saved-prereqsne target)) 260 | (saved-prereqs (target-saved-prereqs target)) 261 | (static-prereqs (target-static-prereqs target)) 262 | (target-does-not-exist? (not (target-exists?/cache target))) 263 | (non-existent-prereqs-exist? 264 | (psome* #'target-exists?/cache prereqsne)) 265 | (regular-prereqs-changed? 266 | (let* ((prereqs 267 | (concatenate 'vector 268 | (map 'vector #'saved-prereq-target saved-prereqs) 269 | static-prereqs)) 270 | (outdated (filter #'out-of-date? prereqs))) 271 | (redo-all outdated) 272 | (psome* #'prereq-changed? saved-prereqs))) 273 | (not-in-db? 274 | (and (target? target) 275 | (not (target-in-db? target))))) 276 | ;; (or target-does-not-exist? 277 | ;; non-existent-prereqs-exist? 278 | ;; regular-prereqs-changed? 279 | ;; not-in-db?) 280 | ;; Return keywords to ease debugging. 281 | (cond (target-does-not-exist? :new) 282 | (non-existent-prereqs-exist? :prereqs) 283 | (regular-prereqs-changed? :changes) 284 | (not-in-db? :unknown) 285 | (t nil)))) 286 | 287 | (defun redo-ifchange (&rest targets) 288 | "Rebuild each target in TARGETS if it is out of date." 289 | (redo-ifchange-all targets)) 290 | 291 | (defun redo-ifchange-target (target) 292 | "Rebuild TARGET if it is out of date." 293 | (setf target (resolve-target target)) 294 | (when (out-of-date? target) 295 | (redo target)) 296 | (record-prereq target)) 297 | 298 | (defun redo-ifchange-all (targets 299 | &key (jobs nproc) 300 | debug) 301 | "Rebuild each target in TARGETS if it is out of date." 302 | (unless (emptyp targets) 303 | (with-build-env (:jobs jobs :debug debug) 304 | (walk-targets #'redo-ifchange-target targets :jobs jobs)))) 305 | 306 | (defun redo-ifcreate (&rest targets) 307 | "Depend on the non-existence of each target in TARGETS." 308 | (redo-ifcreate-all targets)) 309 | 310 | (defun redo-ifcreate-all (targets 311 | &key (jobs nproc) 312 | debug) 313 | "Depend on the non-existence of each target in TARGETS." 314 | ;; Probably not worth parallelizing. 315 | (unless (emptyp targets) 316 | (with-build-env (:jobs jobs :debug debug) 317 | (let ((targets (map 'vector #'resolve-target targets))) 318 | (do-each (target (reshuffle targets)) 319 | (assert (not (target-exists?/cache target)) () 320 | "Target exists: ~a" target) 321 | (record-prereqne target)))))) 322 | 323 | (defun redo-always () 324 | "Depend on an impossible prerequisite. 325 | This ensures that the script for the current target is always run, no 326 | matter what." 327 | (record-prereq impossible-prereq)) 328 | 329 | (defun target-tree (target) 330 | "Return a list of (target . deps), where each dep is also a target 331 | tree. 332 | 333 | As a second value, return the non-existent prereqs." 334 | (let* ((saved-prereqs (target-saved-prereqs target)) 335 | (targets 336 | (append (target-static-prereqs target) 337 | (mapcar #'saved-prereq-target saved-prereqs))) 338 | (deps (mapcar #'target-tree targets)) 339 | (tree (cons target deps))) 340 | (values tree 341 | (target-saved-prereqsne target)))) 342 | -------------------------------------------------------------------------------- /safer-read.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/safer-read 2 | (:use :cl :serapeum) 3 | (:export :safer-read-from-string :safer-read) 4 | (:documentation "Safer variants of read and read-from-string.")) 5 | 6 | (in-package :overlord/safer-read) 7 | 8 | ;;; Adapted from LoL. 9 | 10 | (defparameter *safer-read-blacklist* 11 | '(#\# #+(or) #\: #\|)) 12 | 13 | (def rt (copy-readtable nil)) 14 | 15 | (defun safer-reader-error (stream closech) 16 | (declare (ignore stream closech)) 17 | (error "safer-read failure")) 18 | 19 | (dolist (c *safer-read-blacklist*) 20 | (set-macro-character 21 | c #'safer-reader-error nil rt)) 22 | 23 | (defun safer-read-from-string (s &key fail) 24 | (if (stringp s) 25 | (with-input-from-string (s s) 26 | (safer-read s :fail fail)) 27 | fail)) 28 | 29 | (defun safer-read (s &key fail recursive) 30 | (let ((*readtable* rt) *read-eval*) 31 | (handler-bind 32 | ((error (lambda (condition) 33 | (declare (ignore condition)) 34 | (return-from 35 | safer-read fail)))) 36 | (read s t nil recursive)))) 37 | -------------------------------------------------------------------------------- /specials.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:overlord/specials 2 | (:use #:cl :overlord/types :alexandria :serapeum) 3 | (:import-from :overlord/asdf 4 | :asdf-system-version) 5 | (:import-from #:lparallel 6 | #:*task-priority*) 7 | (:export #:*base* 8 | #:*cli* 9 | #:*db-version* 10 | #:db-version 11 | #:*suppress-phonies* 12 | #:use-threads-p 13 | #:*force* 14 | #:worker-specials 15 | #:register-worker-special 16 | #:unregister-worker-special 17 | #:register-worker-specials 18 | #:unregister-worker-specials 19 | #:wrap-worker-specials 20 | #:*base-package* 21 | #:base-package 22 | #:*jobs*)) 23 | (in-package #:overlord/specials) 24 | 25 | (defvar *worker-specials* '() 26 | "List of special variables that should be propagated into worker threads.") 27 | 28 | (defun worker-specials () 29 | *worker-specials*) 30 | 31 | (defun (setf worker-specials) (value) 32 | (check-type value list) 33 | (assert (every #'symbolp value)) 34 | (assert (setp value)) 35 | (setf *worker-specials* value)) 36 | 37 | (defun register-worker-special (var) 38 | "Register VAR as a variable that should be propagated into worker threads." 39 | (check-type var symbol) 40 | (pushnew var (worker-specials))) 41 | 42 | (defun unregister-worker-special (var) 43 | "Stop VAR from being propagated into worker threads." 44 | (check-type var symbol) 45 | (removef (worker-specials) var)) 46 | 47 | (defun register-worker-specials (vars) 48 | "Register each var in VARS, as with `register-worker-special'." 49 | (mapc #'register-worker-special vars)) 50 | 51 | (defun unregister-worker-specials (vars) 52 | "Unregister each var in VARS as with `unregister-worker-special'." 53 | (mapc #'unregister-worker-special vars)) 54 | 55 | (defun wrap-worker-specials (fn) 56 | "Return a function suitable for passing to a worker that, that 57 | lexically closes over the current dynamic value of every special that has been registered for propagation to worker threads." 58 | (let* ((symbols (worker-specials)) 59 | (symbols (filter #'boundp symbols)) 60 | (values (mapcar #'symbol-value symbols))) 61 | (assert (length= symbols values)) 62 | (lambda (&rest args) 63 | (declare (dynamic-extent args)) 64 | (progv symbols values 65 | (apply fn args))))) 66 | 67 | (register-worker-specials 68 | '(*package* 69 | *readtable* 70 | *read-base* 71 | *read-eval* 72 | *read-default-float-format* 73 | *default-pathname-defaults* 74 | 75 | *standard-output* 76 | ;; Propagating trace output makes debugging much easier. 77 | *trace-output* 78 | *error-output* 79 | 80 | *task-priority* 81 | 82 | ;; Guard against someone trying to alter the list of worker 83 | ;; specials from within a worker. 84 | *worker-specials*)) 85 | 86 | (defvar-unbound *base* "The current base.") 87 | (register-worker-special '*base*) 88 | 89 | (declaim (type (and directory-pathname absolute-pathname) *base*)) 90 | 91 | (defvar *cli* nil "Are we running on a CLI?") 92 | (declaim (type boolean *cli*)) 93 | 94 | (defparameter *db-version* 95 | (parse-integer 96 | (asdf-system-version :overlord)) 97 | "Versioning for fasls. 98 | Incrementing this should be sufficient to invalidate old fasls.") 99 | (declaim (type db-version *db-version*)) 100 | (register-worker-special '*db-version*) 101 | 102 | (defun db-version () 103 | (assure db-version *db-version*)) 104 | 105 | (defvar *use-threads* bt:*supports-threads-p* 106 | "Whether to allow parallelism.") 107 | (declaim (type boolean *use-threads*)) 108 | 109 | (defun use-threads-p () 110 | *use-threads*) 111 | 112 | (defun (setf use-threads-p) (value) 113 | (when value 114 | (unless bt:*supports-threads-p* 115 | (error "This Lisp implementation does not support threads."))) 116 | (setf *use-threads* (true value))) 117 | 118 | (defvar *suppress-phonies* nil) 119 | (declaim (type boolean *suppress-phonies*)) 120 | (register-worker-special '*suppress-phonies*) 121 | 122 | (defvar *force* nil 123 | "Whether to force rebuilding.") 124 | (register-worker-special '*force*) 125 | 126 | (declaim (type package *base-package*)) 127 | (defvar-unbound *base-package* 128 | "The package relative to which (if bound) the base should be computed.") 129 | 130 | (-> base-package () package) 131 | (defun base-package () 132 | (or (bound-value '*base-package*) 133 | *package*)) 134 | 135 | (declaim (type (or null (integer 1 *)) jobs)) 136 | (defvar *jobs* nil) 137 | -------------------------------------------------------------------------------- /stamp.lisp: -------------------------------------------------------------------------------- 1 | ;;; Timestamps and other stamps. This package handles getting and 2 | ;;; comparing timestamps with different (possibly 3 | ;;; implementation-dependent) precisions. 4 | (defpackage :overlord/stamp 5 | (:use :cl :alexandria :serapeum 6 | :local-time) 7 | (:import-from :overlord/types 8 | :universal-time 9 | :file-pathname) 10 | (:import-from :overlord/util :compare) 11 | ;; (:import-from :overlord/version 12 | ;; :version :version-spec :version= :version-compatible?) 13 | (:import-from :fset) 14 | (:shadowing-import-from :trivial-file-size 15 | :file-size-in-octets) 16 | (:export 17 | #:never 18 | #:far-future 19 | #:file-meta 20 | #:file-hash 21 | #:resolved-file 22 | #:target-timestamp 23 | #:stamp 24 | #:timestamp-newer? 25 | #:target-timestamp= 26 | #:stamp= 27 | #:stamp-satisfies-p 28 | #:round-down-to-nearest-second)) 29 | (in-package :overlord/stamp) 30 | 31 | ;;; Timestamps can be exact timestamps (from local-time), universal 32 | ;;; times, the singleton `never' (which means the target 33 | ;;; unconditionally needs building) and the singleton `far-future' 34 | ;;; (which means the target unconditionally does not need building). 35 | 36 | (defunit never) 37 | (defunit far-future) 38 | 39 | (let ((local-time-resolution-bad? 40 | #.(loop repeat 1000 41 | for timestamp = (now) 42 | always (zerop (timestamp-microsecond 43 | timestamp))))) 44 | (when local-time-resolution-bad? 45 | (warn "Local time resolution is too low to be useful."))) 46 | 47 | (deftype target-timestamp () 48 | "Possible formats for the timestamp of a target." 49 | '(or timestamp 50 | universal-time 51 | never 52 | far-future)) 53 | 54 | (defconstructor file-meta 55 | "Metadata to track whether a file has changed." 56 | ;; TODO hash? 57 | (size (integer 0 *)) 58 | (timestamp target-timestamp)) 59 | 60 | (defun file-meta= (x y) 61 | (fset:equal? x y)) 62 | 63 | (defmethod fset:compare ((x file-meta) (y file-meta)) 64 | ;; NB Fset doesn't know how to compare target timestamps. 65 | ;; (fset:compare-slots x y #'file-meta-size #'file-meta-timestamp) 66 | ;; Sort first based on size, then on timestamp. 67 | (let* ((size1 (file-meta-size x)) 68 | (size2 (file-meta-size y)) 69 | (size-order (fset:compare size1 size2))) 70 | (if (not (eql size-order :equal)) 71 | size-order 72 | (let ((ts1 (file-meta-timestamp x)) 73 | (ts2 (file-meta-timestamp y))) 74 | (if (target-timestamp= ts1 ts2) 75 | :equal 76 | :unequal))))) 77 | 78 | (defconstructor file-hash 79 | "The hash of a file. 80 | We store both the size and the hash of the file to further reduce the 81 | already negligible possibility of a collision." 82 | (size (integer 0 *)) 83 | (hash string)) 84 | 85 | (defun file-hash= (x y) 86 | (fset:equal? x y)) 87 | 88 | (defmethod fset:compare ((x file-hash) (y file-hash)) 89 | (fset:compare-slots x y 90 | #'file-hash-size 91 | #'file-hash-hash)) 92 | 93 | (defconstructor resolved-file 94 | "A resolved file. 95 | 96 | This enables a relative file as a target to register as changed if the 97 | file it resolves to changes. 98 | 99 | This is intended for cases (like the `system-resource' target class) 100 | where `redo-ifcreate' isn't enough to detect when a resource has been 101 | shadowed." 102 | (path file-pathname) 103 | (meta (or file-meta file-hash))) 104 | 105 | (defun resolved-file= (x y) 106 | (fset:equal? x y)) 107 | 108 | (defmethod fset:compare ((x resolved-file) (y resolved-file)) 109 | (fset:compare-slots x y 110 | #'resolved-file-path 111 | #'resolved-file-meta)) 112 | 113 | (deftype stamp () 114 | `(or target-timestamp 115 | string 116 | file-meta 117 | file-hash 118 | ;; version-spec 119 | resolved-file)) 120 | 121 | ;; NB Note that conversion from timestamp to universal rounds down 122 | ;; (loses nsecs), so when comparing one of each, whether you convert 123 | ;; the universal time to a timestamp, or the timestamp to a universal 124 | ;; time, actually matters. What we do is to round the more precise to 125 | ;; match the less precise. It might seem perverse to lose information, 126 | ;; but think about it in terms of subtyping relationships. If Y is a 127 | ;; subtype of X, and X has an equality predicate defined on it, then 128 | ;; comparing an instance of X and an instance of Y will only take into 129 | ;; account the information they have in common, and lose the extra 130 | ;; information in Y. 131 | 132 | (defun timestamp-newer? (ts1 ts2) 133 | "Is TS1 greater than TS2?" 134 | (dispatch-case ((ts1 target-timestamp) 135 | (ts2 target-timestamp)) 136 | ((never never) nil) 137 | ((target-timestamp never) t) 138 | ((never target-timestamp) nil) 139 | ((target-timestamp far-future) nil) 140 | ((far-future target-timestamp) t) 141 | 142 | ((timestamp timestamp) 143 | (timestamp> ts1 ts2)) 144 | ((timestamp universal-time) 145 | (> (timestamp-to-universal ts1) ts2)) 146 | 147 | ((universal-time universal-time) 148 | (> ts1 149 | ts2)) 150 | ((universal-time timestamp) 151 | (> ts1 (timestamp-to-universal ts2))))) 152 | 153 | (defun round-down-to-nearest-second (ts) 154 | (etypecase-of target-timestamp ts 155 | ((or never far-future universal-time) ts) 156 | (timestamp 157 | (adjust-timestamp ts 158 | (set :nsec 0))))) 159 | 160 | (defun target-timestamp= (ts1 ts2) 161 | "Is TS1 greater than TS2?" 162 | (dispatch-case ((ts1 target-timestamp) 163 | (ts2 target-timestamp)) 164 | ((timestamp timestamp) 165 | (timestamp= ts1 ts2)) 166 | ((timestamp universal-time) 167 | (= (timestamp-to-universal ts1) ts2)) 168 | 169 | ((universal-time universal-time) 170 | (= ts1 ts2)) 171 | ((universal-time timestamp) 172 | (= ts1 (timestamp-to-universal ts2))) 173 | 174 | ;; This might seem weird, but it's necessary for impossible 175 | ;; targets to always show up as changed, as well as for files that 176 | ;; have been deleted. 177 | ((never never) nil) 178 | ((far-future far-future) t) 179 | ((target-timestamp target-timestamp) nil))) 180 | 181 | (defun stamp= (s1 s2) 182 | (dispatch-case ((s1 stamp) 183 | (s2 stamp)) 184 | ((target-timestamp target-timestamp) 185 | (target-timestamp= s1 s2)) 186 | ((target-timestamp stamp) nil) 187 | 188 | ((string string) 189 | (string= s1 s2)) 190 | ((string stamp) nil) 191 | 192 | ((file-hash file-hash) 193 | (file-hash= s1 s2)) 194 | ((file-hash stamp) nil) 195 | 196 | ((file-meta file-meta) 197 | (file-meta= s1 s2)) 198 | ((file-meta target-timestamp) 199 | (stamp= (file-meta-timestamp s1) s2)) 200 | ((target-timestamp file-meta) 201 | (stamp= s1 (file-meta-timestamp s2))) 202 | ((file-meta stamp) nil) 203 | 204 | ;; ((version-spec version-spec) 205 | ;; (version= s1 s2)) 206 | ;; ((version-spec stamp) nil) 207 | 208 | ((resolved-file resolved-file) 209 | (resolved-file= s1 s2)) 210 | ((resolved-file stamp) nil))) 211 | 212 | (defun stamp-satisfies-p (new old) 213 | "Is stamp NEW practically equivalent to (but not necessarily the 214 | same as) OLD?" 215 | ;; Resist the temptation to compare timestamps chronologically here: 216 | ;; that would plunge us back into the hell of time zones, clock 217 | ;; skew, &c. 218 | (dispatch-case ((new stamp) 219 | (old stamp)) 220 | ;; NB You may want to restore this if we end up supporting semver 221 | ;; in the future. 222 | #+(or) ((version version) 223 | (version-compatible? new old)) 224 | ((stamp stamp) 225 | (stamp= new old)))) 226 | -------------------------------------------------------------------------------- /target-protocol.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/target-protocol 2 | (:use :cl :alexandria :serapeum) 3 | (:import-from :overlord/stamp :target-timestamp :never) 4 | (:import-from :overlord/types :hash-code :error*) 5 | (:import-from :fset :compare :define-cross-type-compare-methods) 6 | (:export 7 | ;; Unit types. 8 | #:root-target 9 | #:impossible-prereq 10 | #:trivial-prereq 11 | ;; Methods that targets should implement. 12 | #:target-stamp 13 | #:target-timestamp 14 | #:target-exists? 15 | #:target= 16 | #:hash-target 17 | #:resolve-target 18 | #:target-build-script 19 | #:target-node-label 20 | #:call-with-target-locked 21 | #:call-with-targets-locked 22 | #:with-target-locked 23 | ;; Other methods. 24 | #:build-script-target 25 | #:run-script 26 | #:record-prereq 27 | #:record-prereqne 28 | #:target-in-db? 29 | #:target-build-time 30 | #:target-static-prereqs 31 | #:target-saved-prereqs 32 | #:target-saved-prereqsne 33 | #:saved-prereq-target 34 | #:saved-prereq-stamp 35 | #:save-temp-prereqs 36 | #:clear-temp-prereqs 37 | #:save-temp-prereqsne 38 | #:clear-temp-prereqsne 39 | #:delete-target 40 | #:delete-targets)) 41 | (in-package :overlord/target-protocol) 42 | 43 | ;;; TODO Add touch-target once you have a good implementation for 44 | ;;; Windows. 45 | 46 | (defunit root-target 47 | "The root target. 48 | Building this builds all targets defined in this session \(not all targets in the database).") 49 | 50 | (defunit impossible-prereq 51 | "The target that is always out of date.") 52 | 53 | (defunit trivial-prereq 54 | "The target that is never out of date.") 55 | 56 | (defmethod compare ((x root-target) (y root-target)) :equal) 57 | (defmethod compare ((x trivial-prereq) (y trivial-prereq)) :equal) 58 | (defmethod compare ((x impossible-prereq) (y impossible-prereq)) :equal) 59 | (define-cross-type-compare-methods root-target) 60 | (define-cross-type-compare-methods impossible-prereq) 61 | (define-cross-type-compare-methods trivial-prereq) 62 | 63 | (defgeneric target-stamp (target) 64 | (:documentation "Return the stamp of TARGET.") 65 | (:method (target) 66 | (target-timestamp target))) 67 | 68 | (defgeneric target-timestamp (target) 69 | (:documentation "Return the timestamp of TARGET.") 70 | (:method (target) 71 | (error* "No timestamp method for target ~a. 72 | 73 | Need to specialize one of ~s or ~s for class ~s." 74 | target 75 | 'target-timestamp 76 | 'target-stamp 77 | (class-name-of target)))) 78 | 79 | (defgeneric (setf target-timestamp) (timestamp target) 80 | (:documentation "Set the timestamp of TARGET. 81 | Not every target type supports this.") 82 | (:method (timestamp target) 83 | (declare (ignore timestamp)) 84 | (error* "Cannot set timestamp for ~a" target))) 85 | 86 | ;; (-> target-exists? (t) boolean) 87 | (defgeneric target-exists? (target) 88 | (:documentation "Does TARGET exists?") 89 | (:method :around (target) 90 | (declare (ignore target)) 91 | (true (call-next-method))) 92 | (:method (target) 93 | (not (eql never (target-stamp target))))) 94 | 95 | ;; (-> target= (t t) boolean) 96 | (defgeneric target= (target1 target2) 97 | (:documentation "Are TARGET1 and TARGET2 the same?") 98 | ;; This is OK because we expect objects representing targets to be 99 | ;; immutable. 100 | (:method (t1 t2) 101 | (eql t1 t2)) 102 | (:method :around (t1 t2) 103 | (or (eql t1 t2) 104 | (call-next-method)))) 105 | 106 | ;; (-> hash-target (t) hash-code) 107 | (defgeneric hash-target (target) 108 | (:documentation "Hash TARGET. 109 | 110 | Two targets that are equal under `target=' should always have the same 111 | hash \(though the reverse is not necessarily true).") 112 | (:method :around (target) 113 | (declare (ignore target)) 114 | (assure hash-code 115 | (call-next-method))) 116 | (:method (target) 117 | (sxhash target))) 118 | 119 | (defgeneric resolve-target (target &optional base) 120 | (:documentation "Resolve any relative pathnames in TARGET. 121 | 122 | TARGET may be returned unchanged if there are no pathnames to resolve, 123 | but it must not be mutated. If there are pathnames to resolve, TARGET 124 | should be copied.") 125 | (:method (target &optional base) 126 | (declare (ignore base)) 127 | target)) 128 | 129 | (defgeneric target-build-script (target)) 130 | 131 | (defgeneric target-node-label (target) 132 | (:documentation "Return a string suitable for logging \(for humans) what target is being built.") 133 | (:method :around (target) 134 | (declare (ignore target)) 135 | (assure string 136 | (call-next-method))) 137 | (:method (target) 138 | (princ-to-string target))) 139 | 140 | (defgeneric call-with-target-locked (target fn) 141 | (:documentation "Call FN with TARGET locked.")) 142 | 143 | (defun call-with-targets-locked (targets fn) 144 | "Lock every target in TARGETS, then call FN. 145 | 146 | Before locking, targets are ordered according to the global order 147 | established by `fset:compare', to avoid deadlocks." 148 | (let ((targets 149 | (fset:stable-sort targets 150 | (op (eql :less (fset:compare _ _)))))) 151 | (funcall 152 | (reduce (lambda (target fn) 153 | (lambda () 154 | (call-with-target-locked target fn))) 155 | targets 156 | :initial-value fn 157 | :from-end t)))) 158 | 159 | (defmacro with-target-locked ((target &key) &body body) 160 | (with-thunk (body) 161 | `(call-with-target-locked ,target ,body))) 162 | 163 | (defgeneric delete-target (target) 164 | (:documentation "Delete TARGET, if it can be deleted.") 165 | (:method (target) 166 | (declare (ignore target)) 167 | (values))) 168 | 169 | (defun delete-targets (&rest targets) 170 | "Delete all targets in TARGETS, in no particular order. 171 | Lists of targets in TARGETS are flattened." 172 | (map nil #'delete-target 173 | (reshuffle (flatten targets)))) 174 | 175 | 176 | 177 | ;;; For internal use. 178 | 179 | (defgeneric build-script-target (script)) 180 | 181 | (defgeneric run-script (task)) 182 | 183 | (defgeneric record-prereq (target) 184 | (:documentation "Record TARGET as a prerequisite of the current parent.")) 185 | 186 | (defgeneric save-temp-prereqs (target)) 187 | 188 | (defgeneric record-prereqne (target)) 189 | 190 | (defgeneric save-temp-prereqsne (target)) 191 | 192 | (defgeneric target-in-db? (target) 193 | (:documentation "Has TARGET been built before?")) 194 | 195 | (defgeneric target-saved-prereqs (target)) 196 | 197 | (defgeneric target-static-prereqs (target) 198 | (:method (target) 199 | (declare (ignore target)) 200 | nil)) 201 | 202 | (defgeneric target-saved-prereqsne (target)) 203 | 204 | (defgeneric saved-prereq-target (prereq)) 205 | 206 | (defgeneric saved-prereq-stamp (prereq)) 207 | 208 | (defgeneric clear-temp-prereqs (target)) 209 | 210 | (defgeneric clear-temp-prereqsne (target)) 211 | 212 | (defgeneric target-build-time (target) 213 | (:documentation "How long (in internal time units) a target took to build.") 214 | (:method (target) 215 | (declare (ignore target)) 216 | 0)) 217 | 218 | (defgeneric (setf target-build-time) (value target)) 219 | -------------------------------------------------------------------------------- /target-table.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/target-table 2 | (:use :cl :alexandria :serapeum) 3 | (:import-from :overlord/target-protocol 4 | :hash-target) 5 | (:export 6 | :target-table 7 | :hash-friendly? 8 | :make-target-table 9 | :with-target-table-locked 10 | :target-table-len 11 | 12 | :target-table-ref 13 | :target-table-rem 14 | :target-table-member 15 | :target-table-keys 16 | :clear-target-table)) 17 | (in-package :overlord/target-table) 18 | 19 | ;;; TODO Rewrite this to use cl-custom-hash-table. I thought it would 20 | ;;; be better to only have only implementation of a target table 21 | ;;; (using Fset) to reduce the maintenance burden, but practically it 22 | ;;; makes the implementation much more complicated. 23 | 24 | (defgeneric hash-friendly? (target) 25 | (:documentation "Can TARGET be used as a key in a EQUAL hash 26 | table?") 27 | (:method ((x package)) t) 28 | (:method ((x symbol)) t) 29 | (:method ((x pathname)) t) 30 | (:method (x) (declare (ignore x)) 31 | nil)) 32 | 33 | (defstruct (target-table (:conc-name target-table.) 34 | (:constructor %make-target-table)) 35 | "A table for storing targets. 36 | This wraps an Fset map (for custom target types) and a hash table \(for built-in types) and keeps them in sync." 37 | (map (fset:empty-map) :type fset:map) 38 | (hash-table (make-hash-table :test 'equal :size 1024) 39 | :type hash-table :read-only t) 40 | (lock (bt:make-recursive-lock) :read-only t) 41 | (synchronized nil :type boolean :read-only t)) 42 | 43 | ;;; Ensure target tables can be written. 44 | 45 | (defmethod print-object ((self target-table) stream) 46 | (when (or (null *print-readably*) 47 | (not *read-eval*)) 48 | (return-from print-object 49 | (call-next-method))) 50 | (write-string (read-eval-prefix self stream) stream) 51 | (format stream "~s" 52 | `(alist-to-target-table 53 | '(,@(target-table-to-alist self))))) 54 | 55 | (-> make-target-table 56 | (&key (:size (integer 0 *)) (:synchronized t)) 57 | target-table) 58 | (defun make-target-table (&key (size 1024) synchronized) 59 | (%make-target-table 60 | :hash-table (make-hash-table :test 'equal 61 | :size (max 1024 size)) 62 | :synchronized synchronized)) 63 | 64 | (defun alist-to-target-table (alist) 65 | (lret* ((len (length alist)) 66 | (table (make-target-table :size len))) 67 | (loop for (k . v) in alist 68 | do (setf (target-table-ref table k) v)))) 69 | 70 | (defmacro with-target-table-locked ((target-table) &body body) 71 | (once-only (target-table) 72 | (with-thunk (body) 73 | `(if (target-table.synchronized ,target-table) 74 | (bt:with-recursive-lock-held ((target-table.lock ,target-table)) 75 | (funcall ,body)) 76 | (funcall ,body))))) 77 | 78 | (-> target-table-len (target-table) array-length) 79 | (defun target-table-len (table) 80 | (with-target-table-locked (table) 81 | (let ((hash-table (target-table.hash-table table)) 82 | (map (target-table.map table))) 83 | (+ (hash-table-count hash-table) 84 | (fset:size map))))) 85 | 86 | (defun target-table-to-alist (table) 87 | (collecting 88 | (let ((hash-table (target-table.hash-table table)) 89 | map) 90 | (with-target-table-locked (table) 91 | (setf map (target-table.map table)) 92 | (do-hash-table (k v hash-table) 93 | (collect (cons k v)))) 94 | (fset:do-map (k v map) 95 | (collect (cons k v)))))) 96 | 97 | (-> target-table-ref (target-table t) (values t boolean)) 98 | (defun target-table-ref (table key) 99 | (with-target-table-locked (table) 100 | (if (hash-friendly? key) 101 | (let ((hash (target-table.hash-table table))) 102 | (gethash key hash)) 103 | (fset:lookup (target-table.map table) key)))) 104 | 105 | (-> (setf target-table-ref) (t target-table t) t) 106 | (defun (setf target-table-ref) (value table key) 107 | (prog1 value 108 | (with-target-table-locked (table) 109 | (if (hash-friendly? key) 110 | (let ((hash (target-table.hash-table table))) 111 | (setf (gethash key hash) value)) 112 | (callf #'fset:with (target-table.map table) key value))))) 113 | 114 | (-> target-table-rem (target-table t) null) 115 | (defun target-table-rem (table key) 116 | (prog1 nil 117 | (with-target-table-locked (table) 118 | (if (hash-friendly? key) 119 | (let ((hash (target-table.hash-table table))) 120 | (remhash key hash)) 121 | (callf #'fset:less (target-table.map table) key))))) 122 | 123 | (-> target-table-member (target-table t) boolean) 124 | (defun target-table-member (table key) 125 | (nth-value 1 126 | (target-table-ref table key))) 127 | 128 | (-> (setf target-table-member) (t target-table t) boolean) 129 | (defun (setf target-table-member) (value table key) 130 | (prog1 (true value) 131 | (if value 132 | (with-target-table-locked (table) 133 | (unless (target-table-member table key) 134 | (setf (target-table-ref table key) t))) 135 | (target-table-rem table key)))) 136 | 137 | (-> target-table-keys (target-table) list) 138 | (defun target-table-keys (table) 139 | (with-target-table-locked (table) 140 | (collecting 141 | ;; Keys from the hash table. 142 | (do-hash-table (k v (target-table.hash-table table)) 143 | (declare (ignore v)) 144 | (collect k)) 145 | ;; Keys from the Fset map. 146 | (fset:do-map (k v (target-table.map table)) 147 | (declare (ignore v)) 148 | (collect k))))) 149 | 150 | (-> clear-target-table (target-table) (values)) 151 | (defun clear-target-table (table) 152 | (with-target-table-locked (table) 153 | (clrhash (target-table.hash-table table)) 154 | (setf (target-table.map table) 155 | (fset:empty-map))) 156 | (values)) 157 | -------------------------------------------------------------------------------- /template/application.lisp: -------------------------------------------------------------------------------- 1 | ;;;; (#| TMPL_VAR name |#).lisp(#| TMPL_IF copyright |#) 2 | ;; 3 | ;;;; (#| TMPL_VAR copyright |#)(#| /TMPL_IF |#) 4 | 5 | (in-package #:(#| TMPL_VAR name |#)) 6 | 7 | (overlord:deftask (#| TMPL_VAR target |#) 8 | ) 9 | -------------------------------------------------------------------------------- /template/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp(#| TMPL_IF copyright |#) 2 | ;; 3 | ;;;; (#| TMPL_VAR copyright |#)(#| /TMPL_IF |#) 4 | 5 | (defpackage #:(#| TMPL_VAR name |#) 6 | (:use #:cl #:alexandria #:serapeum) 7 | (:shadow #:(#| TMPL_VAR target |#)) 8 | (:export #:(#| TMPL_VAR target |#))) 9 | -------------------------------------------------------------------------------- /template/system.asd: -------------------------------------------------------------------------------- 1 | ;;;; (#| TMPL_VAR name |#).asd(#| TMPL_IF copyright |#) 2 | ;; 3 | ;;;; (#| TMPL_VAR copyright |#)(#| /TMPL_IF |#) 4 | 5 | (defsystem "(#| TMPL_VAR name |#)" 6 | :defsystem-depends-on ("overlord") 7 | :class "overlord:overlord-project-system" 8 | :target-name #:(#| TMPL_VAR target |#) 9 | :serial t(#| TMPL_IF depends-on |#) 10 | :depends-on (#| TMPL_VAR dependencies-string |#)(#| /TMPL_IF |#) 11 | :components ((:file "package") 12 | (:file "(#| TMPL_VAR name |#)"))) 13 | -------------------------------------------------------------------------------- /tests.lisp: -------------------------------------------------------------------------------- 1 | (uiop/package:define-package :overlord/tests 2 | (:use :fiveam) 3 | (:mix :cl :serapeum :alexandria) 4 | (:import-from :overlord :with-imports :require-as 5 | :with-import-default :require-default 6 | :depends-on 7 | :cmd :$cmd) 8 | (:import-from :overlord/stamp :timestamp-newer? :never :far-future) 9 | (:import-from :overlord/target :target-timestamp) 10 | (:import-from :overlord/types :overlord-error) 11 | (:import-from :overlord/asdf 12 | :asdf-system-relative-pathname) 13 | (:import-from :local-time :now) 14 | (:import-from :uiop 15 | :native-namestring 16 | :file-exists-p 17 | :absolute-pathname-p 18 | :os-windows-p 19 | :run-program) 20 | (:export :run-overlord-tests :with-temp-db 21 | :touch)) 22 | (in-package :overlord/tests) 23 | 24 | (overlord:set-package-system :overlord) 25 | 26 | (defun nap (&optional (n 1)) 27 | "Sleep until the universal time counter ticks over." 28 | (format t "~&zzz...") 29 | (loop with start = (get-universal-time) 30 | until (< start (get-universal-time)) 31 | do (sleep n)) 32 | (format t "~%")) 33 | 34 | 35 | ;;; Suite. 36 | 37 | (def-suite overlord) 38 | (in-suite overlord) 39 | 40 | 41 | (defun call/temp-db (fn) 42 | (let* (;; Use a random fasl version so we can be reasonably sure 43 | ;; everything is being compiled clean. 44 | (version (random most-positive-fixnum)) 45 | (overlord/specials:*db-version* version) 46 | (overlord/db::*db* nil)) 47 | (unwind-protect 48 | (funcall fn) 49 | (when (equal (overlord/specials:db-version) version) 50 | ;; Busy-wait until we can actually delete the temp db (we may 51 | ;; still be writing to it, regardless of `finish-output'). 52 | (overlord/db:unload-db) 53 | (loop (ignore-errors 54 | (overlord/db:delete-versioned-db) 55 | (return)) 56 | (sleep 1)))))) 57 | 58 | (defmacro with-temp-db ((&key) &body body) 59 | (with-thunk (body) 60 | `(call/temp-db ,body))) 61 | 62 | ;;; Running tests. 63 | (defun run-overlord-tests () 64 | (let ((overlord:*base* (asdf-system-relative-pathname :overlord "")) 65 | (fiveam:*on-error* :debug))) 66 | (with-temp-db () 67 | (run! 'overlord))) 68 | 69 | ;;; Internal use. 70 | (defun debug-test (test) 71 | (let ((overlord:*base* (asdf-system-relative-pathname :overlord "")) 72 | (fiveam:*on-error* :debug) 73 | (fiveam:*on-failure* :debug)) 74 | (run! test))) 75 | 76 | 77 | ;;; Utilities. 78 | 79 | (defun resolve-file (file) 80 | (native-namestring 81 | (if (absolute-pathname-p file) 82 | file 83 | (uiop:merge-pathnames* file (overlord:base))))) 84 | 85 | (defun touch-file (file) 86 | (lret ((file-string (resolve-file file))) 87 | (if (file-exists-p file-string) 88 | (if (os-windows-p) 89 | (run-program 90 | (fmt "powershell (ls \"~a\").LastWriteTime = Get-Date" 91 | (native-namestring file-string))) 92 | (run-program `("touch" ,file-string))) 93 | (prog1 (open file-string :direction :probe 94 | :if-does-not-exist :create) 95 | (assert (file-exists-p file-string)))))) 96 | 97 | (defun touch (&rest targets) 98 | (flet ((touch (target) 99 | (if (typep target '(or pathname string)) 100 | (touch-file target) 101 | (setf (target-timestamp target) (now))))) 102 | (mapcar #'touch targets))) 103 | 104 | ;;; Does the utility work? 105 | (test touch-test 106 | ;; This is more complicated than you might expect, since I want it 107 | ;; to be possible to run the test suite simultaneously in more than 108 | ;; one Lisp instance. 109 | (let ((file 110 | (ensure-directories-exist 111 | (resolve-file 112 | (make-pathname 113 | :name "touch-test" 114 | :directory `(:relative 115 | "tests" 116 | "tmp" 117 | ,(uiop/os:implementation-identifier))))))) 118 | (unless (file-exists-p file) 119 | (touch file) 120 | (nap 1)) 121 | (is (< (file-write-date file) 122 | (progn 123 | (touch file) 124 | (file-write-date file)))))) 125 | 126 | (defmacro disable (&body body) 127 | `(comment ,@body)) 128 | 129 | (test file-target-pathnames-are-readable 130 | (flet ((test-namestring (namestring) 131 | (let* ((path (overlord:ensure-file-target-pathname namestring)) 132 | (path-as-read 133 | (read-from-string (write-to-string path :readably t)))) 134 | (is (pathnamep path-as-read)) 135 | (is (equal path-as-read path)) 136 | (is (uiop:pathname-equal path-as-read path)) 137 | (is (fset:equal? path-as-read path)) 138 | (is (same #'pathname-version (list path path-as-read))) 139 | (is (same #'pathname-type (list path path-as-read)))))) 140 | (test-namestring ".cache/lang/cache") 141 | (test-namestring "") 142 | (test-namestring "x/") 143 | (test-namestring ".x") 144 | (test-namestring "x/y/.z") 145 | (test-namestring "x/y/z"))) 146 | 147 | (test timestamp-newer-regression 148 | (is (not (timestamp-newer? never never))) 149 | (is (not (timestamp-newer? far-future far-future)))) 150 | 151 | 152 | ;;; Definition form tests. 153 | 154 | (overlord:defconfig +literal-string-file+ #p"tests/literal.txt") 155 | 156 | (overlord:define-target-config +literal-string+ 157 | (read-file-into-string +literal-string-file+) 158 | (depends-on '+literal-string-file+) 159 | (depends-on +literal-string-file+)) 160 | 161 | (overlord:define-target-var *literal-string* 162 | (read-file-into-string +literal-string-file+) 163 | (depends-on '+literal-string-file+) 164 | (depends-on +literal-string-file+)) 165 | 166 | (test config/deps 167 | (nap 1) 168 | (local 169 | (def original +literal-string+) 170 | (touch +literal-string-file+) 171 | (overlord:build '+literal-string+) 172 | (is (not (eq original +literal-string+))))) 173 | 174 | (test var/deps 175 | (local 176 | (def string1 *literal-string*) 177 | (is (stringp string1)) 178 | 179 | (nap 1) 180 | 181 | (touch +literal-string-file+) 182 | (overlord:build '*literal-string*) 183 | (def string2 *literal-string*) 184 | (is (stringp string2)) 185 | (is (not (eq string1 string2))) 186 | 187 | (nap 1) 188 | 189 | (touch '+literal-string-file+) 190 | (overlord:build '*literal-string*) 191 | (def string3 *literal-string*) 192 | (is (stringp string3)) 193 | (is (not (eq string2 string3))))) 194 | 195 | (test force-config 196 | "Check that forcing doesn't change the timestamp of a config." 197 | (let ((sym (intern "+HELLO+" :overlord/tests))) 198 | (eval `(overlord:defconfig ,sym "hello")) 199 | (unwind-protect 200 | (let ((stamp (overlord:target-stamp sym))) 201 | (overlord:build sym :force t) 202 | (is (eql stamp (overlord:target-stamp sym)))) 203 | (unintern sym)))) 204 | 205 | (test unbound-config 206 | "Do the right thing if a config somehow ends up unbound." 207 | (if (eql :sbcl uiop:*implementation-type*) 208 | (skip "Can't make configs unbound on SBCL.") 209 | (let ((sym (intern "+GOODBYE+" :overlord/tests))) 210 | (eval `(overlord:defconfig ,sym "goodbye")) 211 | (unwind-protect 212 | (let ((stamp (overlord:target-stamp sym))) 213 | (makunbound sym) 214 | (overlord:build sym) 215 | (is (eql stamp (overlord:target-stamp sym)))) 216 | (unintern sym))))) 217 | 218 | 219 | ;;; Temporary pathnames. 220 | 221 | (defun mktemp () 222 | (uiop:with-temporary-file (:pathname d :keep t) 223 | d)) 224 | 225 | (test temp-pathname-edit-dest 226 | (let ((dest (mktemp))) 227 | (signals overlord-error 228 | (overlord/util:call/temp-file-pathname 229 | dest (lambda (out) 230 | (declare (ignore out)) 231 | (write-string-into-file "hello" dest 232 | :if-exists :supersede)))) 233 | (delete-file dest))) 234 | 235 | (test temp-pathname 236 | (let ((dest (mktemp))) 237 | (overlord/util:call/temp-file-pathname 238 | dest (lambda (out) 239 | (write-string-into-file "hello" out 240 | :if-exists :supersede))) 241 | (is (equal "hello" (read-file-into-string dest))) 242 | (delete-file dest))) 243 | 244 | 245 | ;;; Multiple file stamps. 246 | 247 | (test multiple-file-stamp 248 | (let* ((temps (loop repeat 3 collect (mktemp))) 249 | (stamp (overlord/target::multiple-file-stamp temps))) 250 | (is (stringp stamp)) 251 | (loop for s in '("x" "y" "z") 252 | for temp in temps 253 | do (write-string-into-file s temp :if-exists :supersede)) 254 | (is (not (equal stamp 255 | (overlord/target::multiple-file-stamp temps)))) 256 | (mapc #'delete-file temps))) 257 | 258 | 259 | ;;; Sanity checks. 260 | 261 | (test db-exists 262 | (let ((path (overlord/db::log-file-path))) 263 | (is-true (file-exists-p (overlord/db::log-file-path)) 264 | "DB log does not exist: ~a" path))) 265 | 266 | 267 | ;;; Setting the base. 268 | 269 | (def-suite package-base :in overlord) 270 | (in-suite package-base) 271 | 272 | (defpackage :overlord/test.test-package) 273 | 274 | (def pkg (find-package :overlord/test.test-package)) 275 | 276 | (test package-system 277 | (let ((*package* pkg)) 278 | (overlord:set-package-system :overlord) 279 | (is-true (file-exists-p (overlord:resolve-file "tests/literal.txt"))))) 280 | 281 | (test package-base 282 | (let ((*package* pkg)) 283 | (overlord:set-package-base "" :overlord) 284 | (is-true (file-exists-p (overlord:resolve-file "tests/literal.txt"))))) 285 | 286 | (test package-base-dir 287 | (let ((*package* pkg)) 288 | (overlord:set-package-base "tests/" :overlord) 289 | (is-true (file-exists-p (overlord:resolve-file "literal.txt"))))) 290 | 291 | (test package-base-temp 292 | (let ((*package* pkg)) 293 | (overlord:set-package-base uiop:*temporary-directory*) 294 | (is-false (file-exists-p (overlord:resolve-file "tests/literal.txt"))))) 295 | 296 | (in-suite overlord) 297 | -------------------------------------------------------------------------------- /tests/literal.txt: -------------------------------------------------------------------------------- 1 | literal string 2 | -------------------------------------------------------------------------------- /tests/touch-test: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ruricolist/overlord/551f637ca3f7d682e013e4c6b0b422823087944a/tests/touch-test -------------------------------------------------------------------------------- /types.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :overlord/types 2 | (:use :cl :alexandria :serapeum :uiop/pathname) 3 | (:import-from :uiop/stream :default-temporary-directory) 4 | (:import-from :uiop :getcwd) 5 | (:import-from :trivia :match :let-match1 :ematch 6 | :multiple-value-ematch) 7 | (:import-from :fset :compare :compare-slots 8 | :define-cross-type-compare-methods) 9 | (:export 10 | ;; Conditions. 11 | #:overlord-condition 12 | #:overlord-error 13 | #:overlord-warning 14 | #:overlord-error-target 15 | #:error* 16 | #:warning* 17 | #:cerror* 18 | ;; General types. 19 | #:db-version 20 | #:list-of 21 | #:check-list-of 22 | #:plist 23 | #:universal-time 24 | #:pathname-designator 25 | #:package-designator 26 | #:case-mode 27 | #:hash-code 28 | #:delayed-symbol 29 | #:delay-symbol 30 | #:maybe-delay-symbol 31 | #:force-symbol 32 | #:temporary-file 33 | #:tame-pathname 34 | #:hash-code 35 | ;; Symbols 36 | #:cl-symbol 37 | )) 38 | 39 | (in-package :overlord/types) 40 | 41 | 42 | ;;; Conditions. 43 | 44 | (define-condition overlord-condition (condition) ()) 45 | (define-condition overlord-error (overlord-condition simple-error) ()) 46 | (define-condition overlord-warning (overlord-condition simple-warning) ()) 47 | 48 | (defgeneric overlord-error-target (error)) 49 | 50 | (defun print-current-dir (&optional (stream t)) 51 | "Print the current directory to STREAM. 52 | If the value of `*default-pathname-defaults*' and a call to 53 | `uiop:getcwd' differ, then print them both." 54 | (let ((dpd *default-pathname-defaults*) 55 | (cwd (getcwd))) 56 | (format stream "~2&Working dir: ~s" cwd) 57 | (unless (pathname-equal dpd cwd) 58 | (format stream "~%~s: ~s" 59 | '*default-pathname-defaults* 60 | *default-pathname-defaults*)))) 61 | 62 | (defmethod print-object :after ((x overlord-condition) stream) 63 | (unless *print-escape* 64 | (print-current-dir stream))) 65 | 66 | (defun error* (message &rest args) 67 | (error 'overlord-error 68 | :format-control message 69 | :format-arguments args)) 70 | 71 | (defun cerror* (cont message &rest args) 72 | (cerror cont 73 | 'overlord-error 74 | :format-control message 75 | :format-arguments args)) 76 | 77 | (defun warn* (message &rest args) 78 | (warn 'overlord-warning 79 | :format-control message 80 | :format-arguments args)) 81 | 82 | 83 | ;;; General types. 84 | 85 | (deftype db-version () 86 | '(integer 1 *)) 87 | 88 | (deftype universal-time () 89 | '(integer 0 *)) 90 | 91 | (deftype pathname-designator () 92 | '(or string pathname)) 93 | 94 | (deftype package-designator () 95 | '(or string-designator package)) 96 | 97 | (deftype list-without-nil () 98 | `(and list (satisfies list-without-nil?))) 99 | 100 | (defsubst list-without-nil? (list) 101 | (declare (inline memq)) 102 | (not (memq nil list))) 103 | 104 | (deftype list-of (a) 105 | ;; We don't check that every element is of type A (that could be 106 | ;; expensive) but, if `null' is not a subtype of A, then we do check 107 | ;; that `nil' is not present in the list. It is not sound, but it is 108 | ;; useful. 109 | (if (subtypep 'null a) 110 | ;; XXX Not, of course, recursive, but still catches many 111 | ;; mistakes. 112 | `(or null (cons ,a list)) 113 | `(and list (satisfies list-without-nil?)))) 114 | 115 | (defun check-list-of* (list item-type) 116 | (unless (and (listp list) 117 | (every (of-type item-type) list)) 118 | (error 'type-error 119 | :datum list 120 | :expected-type `(list-of ,item-type)))) 121 | 122 | (defmacro check-list-of (list item-type) 123 | `(check-list-of* ,list ',item-type)) 124 | 125 | (deftype plist () 126 | '(and list (satisfies plist?))) 127 | 128 | (defloop plist? (list) 129 | (declare (optimize speed (debug 0))) 130 | (match list 131 | (() t) 132 | ((list* (and _ (type symbol)) _ list) 133 | (plist? list)) 134 | (otherwise nil))) 135 | 136 | (deftype case-mode () 137 | "Possible values for a readtable's case mode." 138 | '(member :upcase :downcase :preserve :invert)) 139 | 140 | (deftype hash-code () 141 | '(integer 0 #.most-positive-fixnum)) 142 | 143 | (defconstructor delayed-symbol 144 | (package-name string) 145 | (symbol-name string)) 146 | 147 | (defcondition delayed-symbol-error (overlord-error) 148 | ((package-name :type string :initarg :package-name) 149 | (symbol-name :type string :initarg :symbol-name))) 150 | 151 | (defcondition delayed-symbol-package-error (delayed-symbol-error) 152 | () 153 | (:report (lambda (c s) 154 | (with-slots (package-name symbol-name) c 155 | (format s "Cannot force symbol ~a::~a because: no such package as ~a" 156 | package-name 157 | symbol-name 158 | package-name))))) 159 | 160 | (defcondition delayed-symbol-name-error (delayed-symbol-error) 161 | () 162 | (:report (lambda (c s) 163 | (with-slots (package-name symbol-name) c 164 | (format s "Cannot force symbol: no such symbol as ~a::~a" 165 | package-name 166 | symbol-name))))) 167 | 168 | (defun delay-symbol (symbol) 169 | (assure delayed-symbol 170 | (match symbol 171 | ((delayed-symbol) symbol) 172 | ((and _ (type symbol)) 173 | (let* ((package (symbol-package symbol)) 174 | (package-name (package-name package)) 175 | (symbol-name (symbol-name symbol))) 176 | (delayed-symbol package-name symbol-name))) 177 | (otherwise symbol)))) 178 | 179 | (defun force-symbol (delay) 180 | (match delay 181 | ((delayed-symbol package-name symbol-name) 182 | (if-let (package (find-package package-name)) 183 | (receive (symbol status) (find-symbol symbol-name package) 184 | (if (null status) 185 | (error 'delayed-symbol-name-error 186 | :symbol-name symbol-name 187 | :package-name package-name) 188 | symbol)) 189 | (error 'delayed-symbol-package-error 190 | :symbol-name symbol-name 191 | :package-name package-name))) 192 | (otherwise delay))) 193 | 194 | (defun try-force-symbol (delay) 195 | "Try to force delayed symbol DELAY. 196 | 197 | If forcing was successful, return the symbol and, as a second value, T. 198 | 199 | If forcing failed, returned nil and, as a second value, T. 200 | 201 | If DELAY is not a delayed symbol, return it (second value T)." 202 | (match delay 203 | ((delayed-symbol _ _) 204 | (handler-case 205 | (values (force-symbol delay) t) 206 | (delayed-symbol-error () 207 | (values nil nil)))) 208 | ((and _ (type symbol)) (values delay t)) 209 | (otherwise (values delay nil)))) 210 | 211 | (defun delayed-symbol= (ds1 ds2) 212 | (multiple-value-ematch (values ds1 ds2) 213 | (((delayed-symbol p1 s1) 214 | (delayed-symbol p2 s2)) 215 | (and (equal p1 p2) 216 | (equal s1 s2))))) 217 | 218 | (defmethod compare ((ds1 delayed-symbol) (ds2 delayed-symbol)) 219 | (fset:compare-slots ds1 ds2 220 | #'delayed-symbol-package-name 221 | #'delayed-symbol-symbol-name)) 222 | 223 | (defmethod compare ((d delayed-symbol) (s symbol)) 224 | (fset:compare d (delay-symbol s))) 225 | 226 | (defmethod compare ((s symbol) (d delayed-symbol)) 227 | (compare d s)) 228 | 229 | (defun maybe-delay-symbol (symbol) 230 | (cond ((not (symbolp symbol)) 231 | symbol) 232 | ((built-in-symbol? symbol) 233 | symbol) 234 | (t (delay-symbol symbol)))) 235 | 236 | (defun built-in-symbol? (symbol) 237 | (and (symbolp symbol) 238 | (or (keywordp symbol) 239 | (cl-symbol-p symbol) 240 | (when-let ((package (symbol-package symbol))) 241 | (eq package (find-package :overlord/target)))))) 242 | 243 | 244 | ;;; Pathname types. 245 | 246 | (defun temporary-file? (file) 247 | (subpathp file (default-temporary-directory))) 248 | 249 | (deftype temporary-file () 250 | '(and pathname (satisfies temporary-file?))) 251 | 252 | (deftype tame-pathname () 253 | 'non-wild-pathname) 254 | 255 | 256 | ;;; Symbol types. 257 | 258 | (defun cl-symbol-p (x) 259 | (and (symbolp x) 260 | (eql (symbol-package x) 261 | (find-package :cl)))) 262 | 263 | (deftype cl-symbol () 264 | '(and symbol 265 | (not keyword) 266 | (satisfies cl-symbol-p))) 267 | -------------------------------------------------------------------------------- /util.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:overlord/util 2 | (:use :cl :alexandria :serapeum :trivial-file-size) 3 | (:import-from :overlord/types 4 | :case-mode :file-pathname :tame-pathname 5 | :error*) 6 | (:import-from :fset :with :less) 7 | (:import-from :uiop 8 | :enough-pathname 9 | :pathname-directory-pathname 10 | :pathname-parent-directory-pathname 11 | :file-exists-p 12 | :run-program 13 | :native-namestring 14 | :ensure-pathname 15 | :with-temporary-file 16 | :rename-file-overwriting-target 17 | :delete-file-if-exists) 18 | (:import-from :babel :string-to-octets) 19 | (:import-from :bit-smasher :octets->hex) 20 | (:import-from #:local-time 21 | #:nsec-of 22 | #:timestamp-to-universal) 23 | (:export 24 | #:compare 25 | #:locate-dominating-file 26 | #:quoted-symbol? 27 | #:find-external-symbol 28 | #:coerce-case 29 | #:eval* 30 | #:dx-sxhash 31 | #:ensure-pathnamef 32 | #:read-file-form 33 | #:write-form-as-file 34 | #:write-file-if-changed 35 | #:copy-file-if-changed 36 | #:call/temp-file-pathnames 37 | #:call/temp-file-pathname 38 | #:withf 39 | #:lessf 40 | #:with-absolute-package-names 41 | #:resolve-package 42 | #:file-mtime 43 | #:propagate-side-effect 44 | #:byte-array-to-hex-string 45 | #:version-major-version 46 | #:timestamp-diff 47 | #:strip-directory)) 48 | (cl:in-package #:overlord/util) 49 | 50 | (define-modify-macro withf (&rest item-or-tuple) with 51 | "Modify macro for augmenting an Fset map or set.") 52 | 53 | (define-modify-macro lessf (&rest item-or-tuple) less 54 | "Modify macro for removing from an Fset map or set.") 55 | 56 | (defun locate-dominating-file (file name) 57 | (nlet rec ((dir (pathname-directory-pathname file)) 58 | (name (pathname name))) 59 | (if (equal dir (user-homedir-pathname)) 60 | nil 61 | (let ((file (make-pathname :defaults dir 62 | :name (pathname-name name) 63 | :type (pathname-type name)))) 64 | (flet ((rec () 65 | (let ((parent (pathname-parent-directory-pathname dir))) 66 | (if (equal parent dir) 67 | nil 68 | (rec parent name))))) 69 | (if (wild-pathname-p file) 70 | (let ((matches (directory file))) 71 | (if matches 72 | (values (first matches) (rest matches)) 73 | (rec))) 74 | (or (file-exists-p file) 75 | (rec)))))))) 76 | 77 | (defun quoted-symbol? (x) 78 | (and (consp x) 79 | (= (length x) 2) 80 | (eql (first x) 'quote) 81 | (symbolp (second x)))) 82 | 83 | (defun coerce-case (string &key (readtable *readtable*)) 84 | (if (stringp string) 85 | (ecase-of case-mode (readtable-case readtable) 86 | (:upcase (string-upcase string)) 87 | (:downcase (string-downcase string)) 88 | (:preserve string) 89 | (:invert (string-invert-case string))) 90 | (string string))) 91 | 92 | (defun eval* (expr) 93 | "Evaluate EXPR by compiling it to a thunk, then calling that thunk." 94 | (funcall (compile nil (eval `(lambda () ,expr))))) 95 | 96 | (defmacro dx-sxhash (expr) 97 | "Like SXHASH, but try to stack-allocate EXPR." 98 | (with-unique-names (temp) 99 | `(let ((,temp ,expr)) 100 | (declare (optimize (speed 3) (safety 1) (debug 0) 101 | (compilation-speed 0))) 102 | (declare (dynamic-extent ,temp)) 103 | (sxhash ,temp)))) 104 | 105 | (defsubst ensure-pathname* (x) 106 | (ensure-pathname x :want-pathname t)) 107 | 108 | (define-modify-macro ensure-pathnamef () ensure-pathname*) 109 | 110 | (defun read-file-form (file) 111 | (when (file-exists-p file) 112 | (with-standard-io-syntax 113 | (with-open-file (in file :direction :input 114 | :if-does-not-exist nil) 115 | (when in 116 | (prog1 (read in) 117 | (ignoring end-of-file 118 | (read in) 119 | (error "More than one form in ~a" file)))))))) 120 | 121 | (defun write-form-as-file (form file) 122 | (with-standard-io-syntax 123 | (with-open-file (out file 124 | :direction :output 125 | ;; It is possible, when using :supersede, for 126 | ;; the old timestamp to be preserved. 127 | :if-exists :rename-and-delete) 128 | (write form :stream out 129 | :readably t)))) 130 | 131 | (defun existing-file-unchanged? (data file &key (buffer-size 4096)) 132 | (labels ((make-buffer (size) 133 | (make-array (assure array-length size) 134 | :element-type 'octet))) 135 | (let ((buffer (make-buffer buffer-size))) 136 | (with-input-from-file (stream file :element-type 'octet) 137 | (let ((len (file-length stream))) 138 | (and (= (length data) len) 139 | (loop for offset from 0 by buffer-size below len 140 | for end1 = (read-sequence buffer stream) 141 | always (vector= buffer data 142 | :start2 offset 143 | :end1 end1)))))))) 144 | 145 | (defun rename-by-copying (tmp dest) 146 | (copy-file tmp dest 147 | :if-to-exists :rename-and-delete 148 | :finish-output t)) 149 | 150 | (defun call/temp-file-pathname (dest fn) 151 | "Like `call/temp-file-pathnames`, but for a single file." 152 | (call/temp-file-pathnames 153 | (list dest) 154 | (lambda (outs) 155 | (funcall fn (only-elt outs))))) 156 | 157 | (defun call/temp-file-pathnames (dests fn) 158 | "Create a set of temp files, call FN on them, and then copy the temp 159 | files into DESTS." 160 | (let* ((dests (coerce dests 'list)) 161 | (start-times 162 | (mapcar #'file-mtime dests)) 163 | (start-sizes 164 | (mapcar #'file-size-in-octets dests)) 165 | (ok nil) 166 | (tmps 167 | (loop for dest in dests 168 | for extension = (pathname-type dest) 169 | collect (if extension 170 | ;; Preserve the extension. 171 | (with-temporary-file (:pathname p 172 | :keep t 173 | :type extension) 174 | p) 175 | (with-temporary-file (:pathname p 176 | :keep t) 177 | p))))) 178 | (unwind-protect 179 | (progn 180 | (funcall fn tmps) 181 | ;; Check that the destinations have not been written to. 182 | (loop for dest in dests 183 | for start-time in start-times 184 | for start-size in start-sizes 185 | for end-time = (file-mtime dest) 186 | for end-size = (file-size-in-octets dest) 187 | unless (and (eql start-time end-time) 188 | (eql start-size end-size)) 189 | do (error* "Destination file ~a has been written to directly." 190 | dest)) 191 | (loop for tmp in tmps 192 | for dest in dests 193 | do (ensure-directories-exist dest) 194 | if (equal (pathname-device tmp) 195 | (pathname-device dest)) 196 | do (handler-case 197 | (rename-file-overwriting-target tmp dest) 198 | (error () 199 | (rename-by-copying tmp dest))) 200 | else do (rename-by-copying tmp dest)) 201 | (setq ok t)) 202 | (unless ok 203 | (mapc #'delete-file-if-exists tmps))))) 204 | 205 | (defun replace-file-atomically (data dest) 206 | "Write DATA into DEST" 207 | (check-type data octet-vector) 208 | (check-type dest (and file-pathname tame-pathname)) 209 | (let (temp) 210 | (with-temporary-file (:stream out 211 | :direction :output 212 | :element-type 'octet 213 | :pathname p 214 | :keep t 215 | ;; Use the same directory so the overwrite is atomic. 216 | :directory (pathname-directory-pathname dest)) 217 | (write-sequence data out) 218 | (setf temp p)) 219 | (rename-file-overwriting-target temp dest))) 220 | 221 | (defun write-file-if-changed (data file &key (encoding :utf-8) 222 | (buffer-size 4096)) 223 | "Write DATA into FILE only if FILE would change. 224 | DATA may be a string or a byte vector. 225 | 226 | Return T if the file was written to, NIL otherwise." 227 | (ensure-pathnamef file) 228 | (etypecase (assure vector data) 229 | (string 230 | (write-file-if-changed 231 | (string-to-octets data :encoding encoding) 232 | file)) 233 | ((and vector (not octet-vector)) 234 | (write-file-if-changed 235 | (coerce data 'octet-vector) 236 | file)) 237 | (octet-vector 238 | (cond ((not (file-exists-p file)) 239 | (replace-file-atomically data file) 240 | t) 241 | ((existing-file-unchanged? data file :buffer-size buffer-size) 242 | nil) 243 | (t 244 | (replace-file-atomically data file) 245 | t))))) 246 | 247 | (defun copy-file-if-changed (from to) 248 | (ensure-pathnamef from) 249 | (ensure-pathnamef to) 250 | (if (not (file-exists-p to)) 251 | (copy-file from to) 252 | (unless (file= from to) 253 | (copy-file from to :if-to-exists :rename-and-delete)))) 254 | 255 | ;;; Make sure that we treat package names consistently, whether or not 256 | ;;; the Lisp implementation uses package-relative nicknames. 257 | 258 | (defmacro with-absolute-package-names ((&key) &body body) 259 | `(let ((*package* (find-package :keyword))) 260 | ,@body)) 261 | 262 | ;; Maybe this should shadow `find-package'; I'm not sure. 263 | (defun resolve-package (package-designator) 264 | "Like `find-package', but make sure the package is resolved in 265 | absolute terms even if the Lisp implementation supports local package 266 | nicknames." 267 | (with-absolute-package-names () 268 | (find-package package-designator))) 269 | 270 | (defun file-mtime (pathname) 271 | "As `file-write-date', but check if the file exists first. 272 | This is provided in case we ever want to offer more precise timestamps 273 | on Lisp/OS/filesystem combinations that support it, and for 274 | implementations which signal an error rather than returning nil when 275 | PATHNAME does not exist." 276 | (and 277 | (cl:probe-file pathname) 278 | (cl:file-write-date pathname))) 279 | 280 | (defmacro propagate-side-effect (&body body &environment env) 281 | "Force BODY to be evaluated both at compile time AND load time (but 282 | not run time). 283 | 284 | Note that BODY should be idempotent, as it may be evaluated more than 285 | once." 286 | ;; Evaluate it right now, unless we're at the top level (to avoid 287 | ;; warnings about repeated definitions). 288 | (unless (null env) 289 | (eval `(progn ,@body))) 290 | `(progn 291 | ;; Ensure the effect happens both at the top level. 292 | (eval-when (:compile-toplevel :load-toplevel) 293 | ,@body) 294 | ;; Ensure the effect happens at load time when not at the top 295 | ;; level. 296 | (eval-when (:execute) 297 | (load-time-value 298 | (progn ,@body t))) 299 | t)) 300 | 301 | (defun byte-array-to-hex-string (ba) 302 | (octets->hex ba)) 303 | 304 | (defun version-major-version (version) 305 | (etypecase version 306 | (null nil) 307 | ((integer 0 *) version) 308 | (string 309 | (let ((version 310 | (if (string^= "v" version) 311 | (subseq version 1) 312 | version))) 313 | (assure (integer 0 *) 314 | (parse-integer version 315 | :junk-allowed t 316 | :radix 10)))))) 317 | 318 | (defun timestamp-diff (end start) 319 | "Return the difference between END and START, two timestamps, in 320 | nanoseconds." 321 | (let* ((s1 (timestamp-to-universal start)) 322 | (s2 (timestamp-to-universal end)) 323 | (ns1 (nsec-of start)) 324 | (ns2 (nsec-of end)) 325 | (ns1 (+ ns1 (* s1 (expt 10 9)))) 326 | (ns2 (+ ns2 (* s2 (expt 10 9))))) 327 | (- ns2 ns1))) 328 | 329 | (defun strip-directory (pathname) 330 | "Return PATHNAME without its directory (or device)." 331 | (make-pathname 332 | :directory nil 333 | :device nil 334 | :defaults pathname)) 335 | -------------------------------------------------------------------------------- /version.sexp: -------------------------------------------------------------------------------- 1 | "51" 2 | --------------------------------------------------------------------------------