Newer
Older
Francois-Rene Rideau
committed
;;;;; XCVB driver. Load it in your Lisp image and build with XCVB.
Francois-Rene Rideau
committed
;;;; ----- Prelude -----
:author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau"
:licence "MIT" ;; MIT-style license. See LICENSE
Francois-Rene Rideau
committed
:build-depends-on nil))
#.(setf *load-verbose* () *load-print* () *compile-verbose* () *compile-print* ()) ;; Hush!
#+sbcl (declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
Francois-Rene Rideau
committed
;;;; First, try very hard to load a recent enough ASDF.
(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *asdf-version-required-by-xcvb* "3.1.4") ;; for its new run-program
(defvar *asdf-directory*
(merge-pathnames #p"cl/asdf/" (user-homedir-pathname))
"Directory in which your favorite and/or latest version
of the ASDF source code is located")
(defun get-asdf-version ()
(when (find-package :asdf)
(let ((ver (symbol-value
(or (find-symbol (string :*asdf-version*) :asdf)
(find-symbol (string :*asdf-revision*) :asdf)))))
(etypecase ver
(string ver)
(cons (format nil "~{~D~^.~}" ver))
(null "1.0"))))))
;;; Doing our best to load ASDF
;; First, try loading asdf from your implementation.
;; Use funcall to not fail on old CLISP.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(ignore-errors (funcall 'require "asdf"))))
;; If not found, load asdf from wherever the user specified it
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(ignore-errors
(handler-bind ((warning #'muffle-warning))
(let* ((build-asdf-lisp
(merge-pathnames
(make-pathname :directory '(#-gcl :relative "build")
:name "asdf" :type "lisp"
:defaults *asdf-directory*)
*asdf-directory*))
(asdf-lisp
(make-pathname :directory (pathname-directory *asdf-directory*)
:defaults build-asdf-lisp)))
Francois-Rene Rideau
committed
(cond
((probe-file build-asdf-lisp)
(load build-asdf-lisp))
((probe-file asdf-lisp)
(load asdf-lisp))))))))
;; If still not found, error out.
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :asdf *features*)
(error "Could not load ASDF.
Please install ASDF2 and in your ~~/.swank.lisp specify:
(defparameter swank::*asdf-directory* #p\"/path/containing/asdf/\")")))
;;; If ASDF is found, try to upgrade it to the latest installed version.
(eval-when (:compile-toplevel :load-toplevel :execute)
(handler-bind ((warning #'muffle-warning))
(when *asdf-directory*
(pushnew *asdf-directory* (symbol-value (find-symbol (string :*central-registry*) :asdf))
:test 'equal))
(ignore-errors (funcall (fdefinition (find-symbol (string :operate) :asdf))
(find-symbol (string :load-op) :asdf) :asdf :verbose nil))))
;;; If ASDF is too old, punt.
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((ver (get-asdf-version)))
(unless (asdf:version-satisfies ver *asdf-version-required-by-xcvb*)
(error "Your ASDF version ~A is too old for XCVB, which requires ~A.
Please upgrade to the latest stable ASDF and register it in your source-registry."
ver *asdf-version-required-by-xcvb*))))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
;;; We may now assume we have a recent enough ASDF with all the basic driver functions.
(declaim (optimize (speed 2) (space 2) (safety 3) (debug 3) (compilation-speed 0)))
(uiop/package:define-package :xcvb-driver
(:use :uiop/common-lisp :uiop :asdf)
(:reexport :uiop)
;;; special variables shared with XCVB itself
#:*lisp-implementation-type*
#:*lisp-executable-pathname* #:*lisp-image-pathname*
#:*lisp-implementation-directory*
#:*lisp-flags* #:*lisp-allow-debugger*
#:*use-base-image* #:*disable-cfasls*
#:*features-defined* #:*features-undefined*
#:*xcvb-verbosity*
#:*cache* #:*object-cache* #:*workspace*
#:*install-prefix* #:*install-program* #:*install-configuration*
#:*install-data* #:*install-library* #:*install-image* #:*install-lisp*
;;; special variables for XCVB master itself
#:*xcvb-program* #:*manifest*
#:+xcvb-slave-greeting+ #:+xcvb-slave-farewell+
;;; Using an inferior XCVB
Francois-Rene Rideau
committed
#:build-and-load #:bnl #:build-in-slave
;;; Build-time variables
#:*goal* #:*stderr* #:*profiling*
#:*post-image-restart* #:*entry-point*
;;; Environment support
#:debugging #:with-profiling
;; #:run #:do-run ;; -- clashes with inferior-shell
;; #:run-commands #:run-command
Francois-Rene Rideau
committed
#-ecl #:dump-image #+ecl #:create-bundle
#:register-fullname #:register-fullnames #:load-fullname-mappings
#:registered-fullname-pathname))
(in-package :xcvb-driver)
;;; Initial implementation-dependent setup
Francois-Rene Rideau
committed
(eval-when (:compile-toplevel :load-toplevel :execute)
;; otherwise ACL 5.0 may crap out on ASDF dependencies,
;; but even other implementations may have "fun" debugging.
Francois-Rene Rideau
committed
(progn
(let ((*load-verbose* nil)) (require :cmp))
(setf c::*compile-in-constants* t))
#+sbcl (progn
(require :sb-posix)
(proclaim '(sb-ext:muffle-conditions sb-ext:compiler-note)))
(pushnew :xcvb-driver *features*))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
;;;; ----- User-visible variables, 1: Control build in current process -----
;;; Variables used to control building in the current image
(defvar *profiling* nil
"boolean: should we compute and display the time spend in each command?")
Francois-Rene Rideau
committed
(defvar *goal* nil
"what is the name of the goal toward which we execute commands?")
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defvar *initial-random-state* (make-random-state nil)
"initial random state to preserve determinism")
Francois-Rene Rideau
committed
;;;; ----- User-visible variables, 2: Control XCVB -----
;;; These variables are shared with XCVB itself.
Francois-Rene Rideau
committed
(defvar *lisp-implementation-type*
Francois-Rene Rideau
committed
(nth-value 1 (implementation-type))
"Type of Lisp implementation for the target system. A keyword.
Default: same as XCVB itself.")
(defvar *lisp-executable-pathname* nil
"Path to the Lisp implementation to use for the target system.
NIL, or a string.
Default: what's in your PATH.")
(defvar *lisp-image-pathname* nil
"What path to a Lisp image do we need invoke the target Lisp with?
Default: whatever's the default for your implementation.")
(defvar *lisp-implementation-directory*
Francois-Rene Rideau
committed
(lisp-implementation-directory :truename t)
"Where is the home directory for the Lisp implementation,
in case we need it to (require ...) special features?
Default: whatever's the default for your implementation.")
(defvar *lisp-flags* :default
;;; TODO: add support for overriding this feature at the command-line?
"What options do we need invoke the target Lisp with?
A list of strings, or the keyword :DEFAULT.")
(defvar *features-defined* nil
"What additional features to define in the target image")
(defvar *features-undefined* nil
"What additional features to undefine in the target image")
(defvar *disable-cfasls* nil
"Should we disable CFASL support when the target Lisp has it?")
(defvar *xcvb-verbosity* 5
"Level of verbosity of XCVB:
0 - silent except for emergency
5 - usual warnings
9 - plenty of debug info")
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
(defvar *cache* nil
"where to store object files, etc.
NIL: default to $XDG_CACHE_HOME/xcvb/ or $HOME/.cache/xcvb/, see docs")
(defvar *object-cache* nil
"Path to the object cache.
NIL: default to *cache*/*implementation-identifier*/, see docs")
(defvar *workspace* nil
"where to store test and intermediate files private to current run
NIL: default to <current-directory>/workspace/, see docs")
(defvar *install-prefix* nil
"where to install files.
NIL: default to /usr/local/, see docs
\"/\": default to /, with special defaults for other paths.
T: use home directory with special defaults for other paths below.")
(defvar *install-program* nil
"where to install program 'binary' (executable) files.
NIL: default to *install-prefix*/bin, see docs")
(defvar *install-configuration* nil
"where to install configuration files.
NIL: default to *install-prefix*/etc, see docs")
(defvar *install-data* nil
"where to install shared (architecture-independent) data files.
NIL: default to *install-prefix*/share, see docs")
(defvar *install-library* nil
"where to install library (architecture-dependent) files.
NIL: default to *install-prefix*/lib, see docs")
(defvar *install-image* nil
"where to install common-lisp image (architecture- and implementation- dependent) files.
NIL: default to *install-library*/common-lisp/images/, see docs")
(defvar *install-lisp* nil
"where to install common-lisp source code and systems, etc.
NIL: default to *install-data*/common-lisp/, see docs")
(defvar *use-base-image* t
"Should we be using a base image for all builds?")
Francois-Rene Rideau
committed
;;; These variables are specific to a master controlling XCVB as a slave.
Francois-Rene Rideau
committed
(defvar *xcvb-program* "xcvb"
"Path to the XCVB binary (a string), OR t if you want to use an in-image XCVB")
(defvar *required-xcvb-version* "0.600"
"Minimal version of XCVB required for use with this version of the xcvb-driver")
(defvar *source-registry* nil
"CL source registry specification. A sexp or string.
Will override the shell variable CL_SOURCE_REGISTRY when calling slaves.")
(defvar *xcvb-setup* nil
"Lisp file to load to setup the target build system, if any")
(defvar *manifest* nil
;; Note that older versions are kept in the tail, documenting the command history,
;; without affecting the behavior of ASSOC on the alist.
"an alist of the XCVB load commands executed in this image,
with associated pathnames and tthsums.")
Francois-Rene Rideau
committed
;;;; ---- Build and Execution control ----
;;; Performance tweaks
(defun tweak-implementation ()
"Common performance tweaks for various CL implementations."
#+sbcl
(progn
;; add ample margin between GC's: 400 MiB
(setf (sb-ext:bytes-consed-between-gcs) (* 400 1024 1024))
;; add ample margin for *next* GC: 200 MiB
(incf (sb-alien:extern-alien "auto_gc_trigger" sb-alien:long) (* 200 1024 1024))
#|(sb-ext:gc :full t)|#)
(progn
(ccl::configure-egc 32768 65536 98304)
(ccl::set-lisp-heap-gc-threshold (* 384 1024 1024))
(ccl::use-lisp-heap-gc-threshold)
#|(ccl:gc)|#)
nil)
Francois-Rene Rideau
committed
;;; Debugging
Francois-Rene Rideau
committed
(defun debugging (&optional (debug t))
"Enable (or with NIL argument, disable) verbose debugging output from ASDF"
(setf *lisp-interaction* debug
Francois-Rene Rideau
committed
*load-verbose* debug
*load-print* debug
#+clisp custom:*compile-warnings* #+clisp debug
*compile-verbose* debug
*compile-print* debug
*optimization-settings* '((speed 2) (safety 3) (compilation-speed 0) (debug 3)))
(proclaim-optimization-settings)
(cond
(debug
#+sbcl (sb-ext:enable-debugger)
#+clisp (ext:set-global-handler nil nil))
(t
#+sbcl (sb-ext:disable-debugger)
#+clisp (ext:set-global-handler 'error #'bork)))
(values))
;;; Profiling
(defun call-with-maybe-profiling (thunk what goal)
(when *lisp-interaction*
(format! *trace-output* "~&Now ~S~&" what))
(if *profiling*
(let* ((start-time (get-internal-real-time))
(values (multiple-value-list (funcall thunk)))
(end-time (get-internal-real-time))
(duration (coerce (/ (- end-time start-time) internal-time-units-per-second) 'double-float)))
(format! *trace-output* "~&~S~&" `(:profiling ,what :from ,goal :duration ,duration))
(apply #'values values))
(funcall thunk)))
(defmacro with-profiling (what &body body)
"Macro to run a BODY of code, and
profile it under some profiling name when *PROFILING* is enabled."
`(call-with-maybe-profiling #'(lambda () ,@body) ,what *goal*))
Francois-Rene Rideau
committed
;;;; ----- Pathname mappings -----
;; TODO: make it work, test it.
(defvar *pathname-mappings* (make-hash-table :test 'equal)
"Mappings from xcvb fullname to plist of
(physical) :pathname, :logical-pathname, :tthsum digest, etc.")
(defun register-fullname (&key fullname pathname tthsum logical-pathname)
(setf (gethash fullname *pathname-mappings*)
Francois-Rene Rideau
committed
(list :truename (truename* pathname)
Francois-Rene Rideau
committed
:pathname pathname :logical-pathname logical-pathname
:tthsum tthsum))
(values))
(defun register-fullnames (mappings &key (defaults *load-truename*))
(let ((*default-pathname-defaults*
(or (and defaults (truename (pathname-directory-pathname defaults)))
*default-pathname-defaults*)))
(dolist (m mappings)
(apply 'register-fullname m))))
(defun registered-fullname-pathname (fullname)
Francois-Rene Rideau
committed
(let ((plist (gethash fullname *pathname-mappings*)))
(or (getf plist :logical-pathname) (getf plist :truename))))
(defun load-fullname-mappings (file)
(let ((tn (truename file)))
(register-fullnames (read-file-form tn) :defaults tn)))
Francois-Rene Rideau
committed
;;;; ----- The xcvb-driver-command DSL for building Lisp code -----
(fdefinition (find-symbol* designator :xcvb-driver)))
Francois-Rene Rideau
committed
(defun run-command (command)
"Run a single command.
Entry point for XCVB-DRIVER when used by XCVB's farmer"
Francois-Rene Rideau
committed
(proclaim-optimization-settings)
(multiple-value-bind (head args)
(etypecase command
(symbol (values command nil))
(cons (values (car command) (cdr command))))
(apply (function-for-command head) args)))
Francois-Rene Rideau
committed
(defun run-commands (commands)
(map () #'run-command commands))
Francois-Rene Rideau
committed
(declaim (ftype (function () (values)) setup-environment))
(let ((*stderr* *error-output*))
(setup-environment)
Francois-Rene Rideau
committed
(run-commands commands)))
Francois-Rene Rideau
committed
(defmacro run (&rest commands)
"Run a series of XCVB-DRIVER commands, then exit.
Entry point for XCVB-DRIVER when used by XCVB"
`(with-fatal-condition-handler ()
(do-run ',commands)
(quit 0)))
Francois-Rene Rideau
committed
;;;; ----- Simple build commands -----
;;; Loading and evaluating code
(defun do-load (x &key encoding)
(with-muffled-loader-conditions ()
(load* x
:external-format (encoding-external-format (or encoding *default-encoding*))
:verbose (>= *xcvb-verbosity* 8)
:print (>= *xcvb-verbosity* 9))))
(defun load-file (x &key encoding)
(with-profiling `(:load-file ,x :encoding ,encoding)
(unless (do-load x :encoding encoding)
(error "Failed to load ~A" (list x)))))
(defun cl-require (x)
(with-profiling `(:require ,x)
(require x)))
Francois-Rene Rideau
committed
;;; ASDF support
Francois-Rene Rideau
committed
(defun load-asdf (x &key parallel (verbose *compile-verbose*)) ;; parallel loading requires POIU
(when parallel (asdf:load-system :poiu))
(with-profiling `(:asdf ,x)
(with-muffled-loader-conditions ()
(load-system x :verbose verbose))))
Francois-Rene Rideau
committed
(defun initialize-asdf (&key source-registry output-translations)
(asdf:clear-configuration)
(asdf:initialize-source-registry source-registry)
(asdf:initialize-output-translations output-translations))
(defun register-asdf-directory (x)
(pushnew x asdf:*central-registry*))
Francois-Rene Rideau
committed
(defun register-asdf-preloaded-systems (&rest systems)
(dolist (s systems)
(multiple-value-bind (system keys) (if (consp s) (values (car s) (cdr s)) s)
(apply 'asdf/find-system:register-preloaded-system system keys))))
(defun asdf-systems-up-to-date-p (systems &optional (operation 'asdf:load-op))
Francois-Rene Rideau
committed
"Are all the ASDF systems up to date (for loading)?"
(let* ((op (asdf/operation:find-operation () operation))
(plan (asdf/plan:traverse-actions
(loop :for s :in systems
:collect (cons op (find-component () s)))
:plan-class 'asdf/plan:sequential-plan)))
(loop :for (o . c) :in (asdf/plan:plan-actions plan)
Francois-Rene Rideau
committed
:always (asdf:needed-in-image-p o c))))
(defun asdf-systems-up-to-date (&rest systems)
Francois-Rene Rideau
committed
(shell-boolean-exit (asdf-systems-up-to-date-p systems)))
Francois-Rene Rideau
committed
;;; Actually compiling
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defmacro with-determinism (goal &body body)
"Attempt to recreate deterministic conditions for the building a component."
`(call-with-determinism ,goal #'(lambda () ,@body)))
(defun seed-random-state (seed) ; seed is a integer
(declare (ignorable seed))
#+clozure
(flet ((get-bits (&aux bits)
(multiple-value-setq (seed bits) (floor seed ccl::mrg31k3p-limit))
bits))
(multiple-value-bind (x0 x1 x2 x3 x4 x5)
(apply 'values (loop :repeat 6 :collect (get-bits)))
(when (zerop (logior x0 x1 x2))
(setf x0 (logior (get-bits) 1)))
(when (zerop (logior x3 x4 x5))
(setf x3 (logior (get-bits) 1)))
(ccl::initialize-mrg31k3p-state x0 x1 x2 x3 x4 x5)))
#-(or sbcl clozure) (make-random-state *initial-random-state*))
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun call-with-determinism (seed thunk)
;;; The seed is an arbitrary object from (a hash of) which we initialize
;;; all sources of randomness and non-determinism in the file being compiled.
;;;
;;; We typically use as a seed the goal as opposed to the tthsum of some contents
Francois-Rene Rideau
committed
;;; to give a greater chance to trivial modifications of the source text (e.g.
;;; comments and whitespace changes) to be without effect on the compilation output.
Francois-Rene Rideau
committed
;;; We possibly should be using the tthsum instead of a sxhash,
;;; as provided by the master process.
Francois-Rene Rideau
committed
;;;
;;; In SBCL, we'll also need to somehow disable the start-time slot of the
;;; (def!struct (source-info ...)) from main/compiler.lisp (package SB-C),
;;; and override the source location to point to some logical pathname
;;; or somehow a relative pathname.
Francois-Rene Rideau
committed
(let* ((hash (sxhash seed))
(*gensym-counter* 0)
Francois-Rene Rideau
committed
#+sbcl (sb-impl::*gentemp-counter* (* hash 10000))
;;; SBCL will hopefully export a better mechanism soon. See:
Francois-Rene Rideau
committed
;;; https://bugs.launchpad.net/sbcl/+bug/310116
(*random-state* (seed-random-state hash)))
(funcall thunk)))
(defun do-compile-lisp (dependencies source fasl
&key #+sbcl cfasl #+ecl lisp-object around-compile encoding warnings-file)
(let ((*goal* `(:compile-lisp ,source))
(*default-pathname-defaults* (truename *default-pathname-defaults*)))
(multiple-value-bind (output-truename warnings-p failure-p)
(with-profiling `(:preparing-and-compiling ,source)
(with-profiling `(:preparing-compilation-of ,source)
(run-commands dependencies))
(with-profiling `(:compiling ,source)
(with-determinism `(:compiling ,source)
(multiple-value-prog1
(call-around-hook
around-compile
(lambda ()
(apply 'compile-file* source
:output-file (merge-pathnames* fasl)
:external-format (encoding-external-format (or encoding *default-encoding*))
:warnings-file warnings-file
(append
#+sbcl (when cfasl `(:emit-cfasl ,(merge-pathnames* cfasl)))
#+ecl (when lisp-object
`(:object-file #+ecl (merge-pathnames* lisp-object)))))))))))
(declare (ignorable warnings-p failure-p))
(unless output-truename
(die 99 "Compilation Failed for ~A, no fasl created" source))
(values))))
(defun compile-lisp (spec &rest dependencies)
(apply 'do-compile-lisp dependencies spec))
Francois-Rene Rideau
committed
;;; DSL entry point to create images
(defun do-make-image (image dependencies &rest keys
&key output-name executable pre-image-dump post-image-restart entry-point)
(declare (ignore output-name))
(let ((*goal* `(make-image ,image ,dependencies ,@keys))
#+sbcl (*uninteresting-compiler-conditions*
(cons "undefined ~(~A~): ~S" *uninteresting-compiler-conditions*)))
(with-muffled-compiler-conditions ()
(run-commands dependencies))
(setf *image-prelude* post-image-restart)
(setf *image-postlude* pre-image-dump)
(setf *image-entry-point* entry-point)
(dump-image image :executable executable)))
#+ecl ;; wholly untested and probably buggy.
(defun do-make-image (image dependencies &rest keys
&key kind executable output-name pre-image-dump post-image-restart entry-point)
(declare (ignore pre-image-dump))
(let ((*goal* `(make-image ,image ,dependencies ,@keys))
Francois-Rene Rideau
committed
(kind (or kind (if executable :program :shared-library)))
(first-dep (car dependencies)))
(multiple-value-bind (object-files manifest)
(case (first first-dep)
((:load-manifest)
(assert (null (rest dependencies)))
(let ((manifest (read-file-form (second first-dep))))
Francois-Rene Rideau
committed
(loop :for l :in manifest
:collect
(destructuring-bind (&key command parent pathname
tthsum source-pathname source-tthsum) l
(declare (ignore tthsum source-pathname source-tthsum))
(assert (eq (car command) :load-file))
pathname))
Francois-Rene Rideau
committed
(loop :for l :in dependencies
:collect
(destructuring-bind (link-file pathname) l
(assert (eq link-file :load-file))
pathname)))
(t
(assert (null dependencies))))
Francois-Rene Rideau
committed
kind (pathname image)
Francois-Rene Rideau
committed
:init-name (c::compute-init-name (or output-name image) :kind kind)
:prelude
(when (eq kind :program)
`(progn
Francois-Rene Rideau
committed
(setf xcvb-driver:*manifest* ',(reverse manifest))
,@(etypecase post-image-restart
Francois-Rene Rideau
committed
(null)
(cons (list prelude))
(string `((standard-eval-text ',post-image-restart))))))
Francois-Rene Rideau
committed
:entry-point entry-point))))
(defun make-image (spec &rest dependencies)
(destructuring-bind (image &rest keys) spec
(apply 'do-make-image image dependencies keys)))
Francois-Rene Rideau
committed
;;;; ----- CFFI-grovel support -----
(defun process-cffi-grovel-file (input c exe output &key cc-flags)
(destructuring-bind (input c exe output)
(mapcar 'fullname-pathname (list input c exe output))
(with-current-directory (exe)
(progv (list (find-symbol* :*cc-flags* :cffi-grovel)) (list cc-flags)
(symbol-call :cffi-grovel :generate-c-file input c)
(symbol-call :cffi-grovel :cc-compile-and-link c exe)
(symbol-call :cffi-grovel :invoke exe output)))))
(defun process-cffi-wrapper-file (input c so output &key cc-flags)
(declare (ignore output)); see below
(flet ((f (x) (native-namestring (merge-pathnames x))))
(let* ((input (f input))
(c (f c))
(so (f so))
;;(output (f output))
(*default-pathname-defaults* (pathname-directory-pathname so)))
(progv (list (find-symbol* :*cc-flags* :cffi-grovel)) (list cc-flags)
(with-safe-io-syntax ()
(multiple-value-bind (c-file lisp-forms)
(symbol-call :cffi-grovel :generate-c-lib-file input c)
(declare (ignore c-file))
(symbol-call :cffi-grovel :cc-compile-and-link c so :library t)
(values (symbol-call :cffi-grovel :generate-bindings-file
c so lisp-forms c)
;; currently use C instead of OUTPUT, due to output locations.
;; ugly, but generate-bindings-file already adds .grovel-tmp.lisp
;; to the output name, so we reuse the c name here. Sigh.
so)))))))
;;; Magic strings. Do not change. Constants, except we can't portably use defconstant here.
Francois-Rene Rideau
committed
(defvar +xcvb-slave-greeting+ #.(format nil "Dear Master, here are your build commands:~%"))
(defvar +xcvb-slave-farewell+ #.(format nil "~%Your desires are my orders, sincerely, XCVB.~%"))
Francois-Rene Rideau
committed
;;;; ----- Manifest: representing how an image was built or is to be built -----
;;; Maintaining memory of which grains have been loaded in the current image.
;; TODO: fix brokenness. We need to distinguish
;; 1- either a grain or a virtual command that we issue, e.g. (:load-file (:fasl "/foo/bar"))
;; 2- the actual thing that the driver runs, e.g. (:load-file "/path/to/foo/bar.fasl")
;; The mapping can be done at one place or the other, but currently there's a big confusion!
(defun process-manifest-entry (&rest entry &key command pathname tthsum encoding &allow-other-keys)
;; also source source-tthsum source-pathname
(unless (and tthsum
(equal tthsum
(getf (find command *manifest* :test #'equal
:key (lambda (x) (getf x :command)))
:tthsum))
(progn
(when (>= *xcvb-verbosity* 8)
(format! *error-output* "~&Skipping XCVB command ~S ~@[from already loaded file ~S (tthsum: ~A)~]~%"
command pathname tthsum))
t))
(when (>= *xcvb-verbosity* 7)
(format! *error-output* "~&Loading XCVB grain ~S~@[ pathname: ~S~]~@[ (tthsum: ~A)~]~%"
command pathname tthsum))
(cond
(pathname
(assert (and (consp command) (eq :load-file (car command))
(consp (cdr command)) (null (cddr command))))
(load pathname
:external-format (encoding-external-format encoding)
:verbose (>= *xcvb-verbosity* 8)
:print (>= *xcvb-verbosity* 9)))
(t
(run-command command)))
(push entry *manifest*)))
(defun process-manifest (manifest)
(dolist (entry manifest)
(apply 'process-manifest-entry entry)))
(defun initialize-manifest (pathname)
(assert (not *manifest*))
(setf *manifest* (reverse (read-file-form pathname))))
(defun load-manifest (pathname)
(process-manifest (read-file-form pathname)))
;;;; ----- XCVB automagic bootstrap: creating XCVB if not there yet -----
(defvar *xcvb-present* nil)
(defun default-xcvb-program ()
(native-namestring
(subpathname
(user-homedir-pathname)
(format nil ".cache/common-lisp/bin/~(~A~@[-~A~]~)/xcvb"
(operating-system) (architecture)))))
Francois-Rene Rideau
committed
(defun xcvb-present-p (&optional (program *xcvb-program*))
;; returns the resolved path to xcvb if present
(or (and (equal program *xcvb-present*) program)
(etypecase program
((eql t) (and (find-package :xcvb) (setf *xcvb-present* t)))
(string
Francois-Rene Rideau
committed
(and
(string-prefix-p "XCVB version "
Francois-Rene Rideau
committed
(list program "version")
:ignore-error-status t :output :string))
Francois-Rene Rideau
committed
(setf *xcvb-present* program)))
(pathname
(xcvb-present-p (native-namestring program))))
(when (equal program "xcvb")
(let ((default (default-xcvb-program)))
(assert (not (equal default "xcvb")))
(xcvb-present-p default)))
(setf *xcvb-present* nil)))
(declaim (ftype (function (t) string) build-xcvb)) ; avoid warning on forward reference.
(defun create-xcvb-program (&optional (program *xcvb-program*))
Francois-Rene Rideau
committed
;; Ugly: May side-effect *xcvb-program* to point to the resolved location of xcvb.
(when (equal program "xcvb")
Francois-Rene Rideau
committed
(setf program (default-xcvb-program))
(when (equal *xcvb-program* "xcvb")
(setf *xcvb-program* program)))
Francois-Rene Rideau
committed
(asdf:load-system :xcvb-bootstrap)
Francois-Rene Rideau
committed
(funcall 'build-xcvb program))
(defun require-xcvb ()
(asdf:load-system :xcvb)
Francois-Rene Rideau
committed
Francois-Rene Rideau
committed
(defun ensure-xcvb-present (&optional (program *xcvb-program*))
;; returns the resolved path to the xcvb binary
(or (xcvb-present-p program)
(etypecase program
((eql t) (require-xcvb))
((or string pathname) (create-xcvb-program program)))))
Francois-Rene Rideau
committed
;;;; ----- XCVB master: calling XCVB -----
;;; Run a slave, obey its orders. (who's the master?)
;;; TODO: detect whether XCVB is installed or reachable, have fall back plan
;;; 1- fall back to executing a lisp that invokes asdf to bootstrap xcvb
;;; (requires a merge of lisp-invocation into driver) (use SBCL? clisp? ccl?)
;;; 2- fall back to loading xcvb in the current image
(defparameter *bnl-keys-with-defaults*
Francois-Rene Rideau
committed
'((xcvb-program *xcvb-program*)
(required-xcvb-version *required-xcvb-version*)
(setup *xcvb-setup*)
(source-registry *source-registry*)
(output-path nil)
(lisp-implementation *lisp-implementation-type*)
(lisp-binary-path *lisp-executable-pathname*)
(lisp-image-path *lisp-image-pathname*)
(features-defined *features-defined*)
(features-undefined *features-undefined*)
(disable-cfasl *disable-cfasls*)
(use-base-image *use-base-image*)
(cache *cache*)
(object-cache *object-cache*)
(workspace *workspace*)
(install-prefix *install-prefix*)
(install-program *install-program*)
(install-configuration *install-configuration*)
(install-data *install-data*)
(install-library *install-library*)
(install-image *install-image*)
(install-lisp *install-lisp*)
(verbosity *xcvb-verbosity*)
(debugging *lisp-interaction*)
(profiling nil)))
(defparameter *bnl-keys* (mapcar #'car *bnl-keys-with-defaults*)))
(defun build-slave-command-line (build &key . #.*bnl-keys-with-defaults*)
(flet ((list-option-arguments (string values)
(loop
:for value :in values
:nconc (list string value))))
(macrolet
((to-option-name (name)
(format nil "--~(~a~)" name))
(pathname-option (var)
`(when ,var
(list (to-option-name ,var) (native-namestring ,var))))
(string-option (var)
`(when ,var
(list (to-option-name ,var) (let ((*print-case* :downcase))
(princ-to-string ,var)))))
(boolean-option (var)
`(when ,var
(list (to-option-name ,var))))
(pluralize (wrapper &rest vars)
`(append ,@(loop :for var :in vars :collect `(,wrapper ,var))))
(string-options (&rest vars)
`(pluralize string-option ,@vars))
(pathname-options (&rest vars)
`(pluralize pathname-option ,@vars))
(boolean-options (&rest vars)
`(pluralize boolean-option ,@vars)))
(append
Francois-Rene Rideau
committed
(list "slave-builder")
(string-options build setup lisp-implementation source-registry
verbosity required-xcvb-version)
Francois-Rene Rideau
committed
(pathname-options output-path lisp-binary-path lisp-image-path
xcvb-program cache object-cache workspace
install-prefix install-program install-configuration
install-data install-library install-image install-lisp)
(list-option-arguments "define-feature" features-defined)
(list-option-arguments "undefine-feature" features-undefined)
(boolean-options disable-cfasl use-base-image debugging profiling)))))
Francois-Rene Rideau
committed
(defun run-xcvb-command (program command)
(etypecase program
(string
Francois-Rene Rideau
committed
;; Ugly: rely on the above having side-effected *xcvb-program*
Francois-Rene Rideau
committed
(with-safe-io-syntax ()
(cons program command) :output :string :ignore-error-status t)))
Francois-Rene Rideau
committed
(pathname
Francois-Rene Rideau
committed
(run-xcvb-command (namestring program) command))
Francois-Rene Rideau
committed
((eql t)
(unless (find-symbol* :cmd :xvcb nil)
(require-xcvb))
(with-safe-io-syntax ()
(with-output-to-string (*standard-output*)
(apply 'symbol-call :xcvb :cmd command))))))
Francois-Rene Rideau
committed
(defun build-in-slave (build &rest args &key . #.*bnl-keys-with-defaults*)
Francois-Rene Rideau
committed
"Entry point to call XCVB to build (but not necessarily load) a system."
Francois-Rene Rideau
committed
(declare (ignore . #.(set-difference *bnl-keys* '(xcvb-program verbosity))))
Francois-Rene Rideau
committed
(let* ((xcvb-program (ensure-xcvb-present xcvb-program))
(slave-command (apply 'build-slave-command-line build :xcvb-program xcvb-program args))
Francois-Rene Rideau
committed
(slave-output (run-xcvb-command xcvb-program slave-command))
Francois-Rene Rideau
committed
(slave-greeting-pos (search +xcvb-slave-greeting+ slave-output :from-end t))
(manifest
(progn
(unless (and slave-output
Francois-Rene Rideau
committed
slave-greeting-pos
(string-suffix-p slave-output +xcvb-slave-farewell+))
(format! *error-output*
"Failed to execute a build slave.~%~
Slave command:~% ~S~%~
Slave output:~%~A~%~
Francois-Rene Rideau
committed
(If using SLIME, you might have useful error output in your *inferior-lisp* buffer~%in which case next time you may M-x slime-redirect-inferior-output.)"
slave-command slave-output)
(error "XCVB slave failed"))
(read-from-string
slave-output t nil
Francois-Rene Rideau
committed
:start (+ (length +xcvb-slave-greeting+) slave-greeting-pos)
:end (- (length slave-output) (length +xcvb-slave-farewell+)))))
(*xcvb-verbosity* (+ (or verbosity *xcvb-verbosity*) 2)))
(when (>= *xcvb-verbosity* 9)
(format! *error-output* "~&Slave XCVB returned following manifest:~%~S~%" manifest))
manifest))
(defun build-and-load (build &rest args &key . #.*bnl-keys*)
Francois-Rene Rideau
committed
"Entry point for users to call XCVB to build and load a system."
(declare (ignore . #.*bnl-keys*))
(process-manifest (apply 'build-in-slave build args)))
(defun bnl (build &rest keys &key . #.*bnl-keys*)
"Short hand for BUILD-AND-LOAD"
(declare (ignore . #.*bnl-keys*))
(apply 'build-and-load build keys))
Francois-Rene Rideau
committed
;;; Build initialization
(defun setup-environment ()
"Setup the XCVB environment with respect to debugging, profiling, performance"
(setf *lisp-interaction* (getenvp "XCVB_DEBUGGING"))
Francois-Rene Rideau
committed
(setf *profiling* (getenvp "XCVB_PROFILING"))
(tweak-implementation)
(values))
Francois-Rene Rideau
committed
;;;; ----- The End -----