Relax requirement on current directory during build

After this it is more-or-less possible to have the SBCL root directory
be a subdirectory of the current dir. Everything in src/cold finds required
files as siblings, so if SBCL is in "mumble/something/sbcl", you needn't
change dir into "sbcl" but instead, while in "mumble" it works to load
"something/sbcl/src/cold/shared"

A quick not-too-exciting example:
* (setq *sbcl-local-target-features-file* "sbcl/local-target-features.lisp-expr")
"sbcl/local-target-features.lisp-expr"
* (load "sbcl/src/cold/shared")
T

In real-world usage, the SBCL directory would be buried deeper in the tree
and you don't want to physically change dir into it because reasons.

It should be easier to parallelize crossbuild-runner too. With suitable
input and output directories, each architecture can place its artifacts into
a different fasl tree while pulling sources from the common location.
This commit is contained in:
Douglas Katzman 2021-06-30 00:15:35 -04:00
parent 505a80c975
commit 0abf67fd58
21 changed files with 110 additions and 112 deletions

View file

@ -12,6 +12,7 @@ time $SBCL_XC_HOST <<EOF
(load "src/cold/set-up-cold-packages.lisp")
(load "tools-for-build/corefile.lisp")
(in-package "SB-COLD")
(defvar *target-sbcl-version* (read-from-file "version.lisp-expr"))
(in-host-compilation-mode
(lambda (&aux (sb-xc:*features* (cons :c-headers-only sb-xc:*features*)))
(do-stems-and-flags (stem flags 1)

View file

@ -3,7 +3,7 @@
(let ((*print-pretty* nil)
(*print-length* nil))
(dolist (thing '(("SB-XC" "*FEATURES*")
("SB-COLD" "*SHEBANG-BACKEND-SUBFEATURES*")))
("SB-COLD" "BACKEND-SUBFEATURES")))
(let* ((sym (intern (cadr thing) (car thing)))
(val (symbol-value sym)))
(when val

View file

@ -99,7 +99,7 @@
;; As each platform's build becomes warning-free,
;; it should be added to the list here to prevent regresssions.
(when (and likely-suspicious
(featurep '(:and (:or :x86 :x86-64) (:or :linux :darwin))))
(target-featurep '(:and (:or :x86 :x86-64) (:or :linux :darwin))))
(warn "Expected zero inlinining failures"))))
;; After cross-compiling, show me a list of types that checkgen

View file

@ -1,8 +1,5 @@
;; If you change this, note that 'slam.lisp' has to be able to parse this form
(mapc (lambda (x)
(load (merge-pathnames (stem-remap-target x)
(make-pathname :type "lisp"))
:verbose nil :print nil))
(mapc (lambda (x) (load (sb-cold:stem-source-path x) :verbose nil :print nil))
'("src/assembly/{arch}/tramps"
"src/assembly/{arch}/assem-rtns"
"src/assembly/{arch}/array"

View file

@ -16,6 +16,5 @@
"SBCL")
(defun lisp-implementation-version ()
;; Read the version file once and once only
#+sb-xc-host #.(sb-cold:read-from-file "version.lisp-expr")
#+sb-xc-host #.sb-cold:*target-sbcl-version*
#-sb-xc-host #.(lisp-implementation-version))

View file

@ -60,9 +60,7 @@
(macrolet ((frob ()
(flet ((file (name type)
(let ((dir (sb-cold:prepend-genfile-path "output/")))
(make-pathname :directory (pathname-directory (merge-pathnames dir))
:name name :type type)))
(sb-cold:find-bootstrap-file (format nil "output/~A.~A" name type)))
(read-ub8-vector (pathname)
(with-open-file (stream pathname
:element-type '(unsigned-byte 8))

View file

@ -23,8 +23,7 @@
(defstruct package-data name doc shadow export reexport import-from use)
(export 'package-data)
(dolist (data (with-open-file (f (merge-pathnames "../../package-data-list.lisp-expr"
*load-pathname*))
(dolist (data (with-open-file (f (merge-pathnames "package-data-list.lisp-expr" *load-pathname*))
(read f)))
(labels ((flatten (tree)
(mapcan (lambda (x) (if (listp x) (flatten x) (list x)))
@ -43,7 +42,7 @@
(when (sb-int:system-package-p (find-package name))
(sb-ext:unlock-package package))))
;;; Define this first to avoid a style-warning from 'shebang'
;;; Restore target floating-point number syntax
(defun read-target-float (stream char)
(declare (ignore stream char))
(values)) ; ignore the $ as if it weren't there

View file

@ -23,7 +23,7 @@
;;; (i.e. do it in source code using #[-+]sb-xc-host).
;;; The target compiler will still get everything as usual.
(let ((*features* (cons :sb-xc *features*)))
(load "src/cold/muffler.lisp"))
(load (sb-cold:find-bootstrap-file "^muffler")))
;;; Ordinarily the types carried around as "handled conditions" while compiling
;;; have been parsed into internal CTYPE objects. However, using parsed objects

View file

@ -97,6 +97,10 @@
(sb-cold::exit-process 1)))))
(format t "~&; Parallel build: Skipping fasl load~%"))
;;; Read the version file once and once only,
;;; or not at all if you've otherwise defined this.
(defvar *target-sbcl-version* (read-from-file "version.lisp-expr"))
;;; Either load or compile-then-load the cross-compiler into the
;;; cross-compilation host Common Lisp.
(defun load-or-cload-xcompiler (load-or-cload-stem)

View file

@ -378,7 +378,7 @@
(import x cl-model-package)
(export x cl-model-package)))
(reexport (list nil))
(dolist (string (read-from-file "common-lisp-exports.lisp-expr"))
(dolist (string (read-from-file "^common-lisp-exports.lisp-expr"))
(unless (string= string "NIL") ; already done
(cond ((member string *undefineds* :test #'string=)
(new-external string cl-model-package))
@ -482,7 +482,7 @@
(export '*undefined-fun-allowlist*)
(defvar *undefined-fun-allowlist* (make-hash-table :test 'equal))
(let ((list
(with-open-file (data (prepend-genfile-path "package-data-list.lisp-expr"))
(with-open-file (data (find-bootstrap-file "^package-data-list.lisp-expr"))
;; There's no need to use the precautionary READ-FROM-FILE function
;; with package-data-list because it is not a customization file.
(create-target-packages (let ((*readtable* *xc-readtable*)) (read data)))
@ -515,7 +515,7 @@
(defun package-list-for-genesis ()
(append (let ((*readtable* *xc-readtable*))
(read-from-file "package-data-list.lisp-expr" nil))
(read-from-file "^package-data-list.lisp-expr" nil))
(let ((asm-package (backend-asm-package-name)))
(list (make-package-data :name asm-package
:use (list* "CL" *asm-package-use-list*)
@ -525,7 +525,8 @@
;;; by the tree-shaker as intended.
#+nil
(defun show-unused-exports (&aux nonexistent uninteresting)
(dolist (entry (with-open-file (f "package-data-list.lisp-expr") (read f)))
(dolist (entry (with-open-file (find-bootstrap-file "^package-data-list.lisp-expr")
(read f)))
(let ((pkg (find-package (package-data-name entry))))
(dolist (string (mapcan (lambda (x) (if (stringp x) (list x) x))
(package-data-export entry)))

View file

@ -164,24 +164,42 @@
(rename-file x path)))
(compile 'rename-file-a-la-unix)
(export '(prepend-genfile-path read-from-file *generated-sources-root*))
(export '(*target-sbcl-version* *generated-sources-root*
stem-source-path find-bootstrap-file read-from-file))
(defvar *sources-root* "")
(defvar *generated-sources-root* "")
(defvar *src-cold-shared-pathname* *load-pathname*)
;;; See remark in COMPILE-STEM about strings vs. The Common Lisp Way
(defun prepend-genfile-path (namestring)
(concatenate 'string
;; if exact match to "output/", or mismatch at the next character
(if (member (mismatch "output/" namestring) '(nil 7))
*generated-sources-root*
"")
namestring))
(compile 'prepend-genfile-path) ; seems in vogue to compile everything in this file
(defun find-bootstrap-file (namestring)
(cond ((char= (char namestring 0) #\^)
;; If it starts with a "^" then it means "src/cold/..."
(let ((this *src-cold-shared-pathname*)
(name (subseq namestring 1)))
(make-pathname :host (pathname-host this)
:device (pathname-device this)
:directory (pathname-directory this)
:name (pathname-name name)
:type (or (pathname-type name) (pathname-type this)))))
((find #\/ namestring)
;; Otherwise if it contains a slash, then it's a source file which is either
;; in the tree as checked in, or generated by a prior build step.
(concatenate 'string
(if (eql (mismatch "output/" namestring) 7) ; a generated source
*generated-sources-root*
*sources-root*)
namestring))
(t
;; Else, it's an optional user-supplied customization file,
;; or a generated data file in the root directory such as "version.lisp-expr"
namestring)))
(compile 'find-bootstrap-file) ; seems in vogue to compile everything in this file
;;; Return an expression read from the file named NAMESTRING.
;;; For user-supplied inputs, protect against more than one expression
;;; appearing in the file. With trusted inputs we needn't bother.
;;; appearing in the file. For in-tree inputs we needn't bother.
(defun read-from-file (namestring &optional (enforce-single-expr t))
(with-open-file (s (prepend-genfile-path namestring))
(with-open-file (s (find-bootstrap-file namestring))
(let* ((result (read s))
(eof-result (cons nil nil)))
(unless enforce-single-expr
@ -202,7 +220,7 @@
#+sbcl
(progn
(setq cl:*compile-print* nil)
(load "src/cold/muffler.lisp")
(load (find-bootstrap-file "^muffler"))
;; Let's just say we never care to see these.
(declaim (sb-ext:muffle-conditions
(satisfies unable-to-optimize-note-p)
@ -212,16 +230,17 @@
;;;; special read-macros for building the cold system (and even for
;;;; building some of our tools for building the cold system)
(load "src/cold/shebang.lisp")
(load (find-bootstrap-file "^shebang"))
(defvar *shebang-backend-subfeatures*
(let* ((default-subfeatures nil)
(customizer-file-name "customize-backend-subfeatures.lisp")
(customizer (if (probe-file customizer-file-name)
(compile nil
(read-from-file customizer-file-name))
#'identity)))
(funcall customizer default-subfeatures)))
;;; Subfeatures could be assigned as late as the beginning of make-host-2,
;;; but I don't want to introduce another mechanism for delaying reading
;;; of the customizer just because we can.
;;; But it's not well-advertised; does it really merit a customization file?
(export 'backend-subfeatures)
(defvar backend-subfeatures
(let ((customizer-file-name "customize-backend-subfeatures.lisp"))
(when (probe-file customizer-file-name)
(copy-list (funcall (compile nil (read-from-file customizer-file-name)) nil)))))
;;; When cross-compiling, the *FEATURES* set for the target Lisp is
;;; not in general the same as the *FEATURES* set for the host Lisp.
@ -237,46 +256,44 @@
;;; The compromise is to examine a variable specifying a path
;;; (and it can't go in SB-COLD because the package is not made soon enough)
(setf sb-xc:*features*
(let* ((pathname (let ((var 'cl-user::*sbcl-target-features-file*))
(let* ((pathname (let ((var 'cl-user::*sbcl-local-target-features-file*))
(if (boundp var)
(symbol-value var)
"local-target-features.lisp-expr")))
(default-features
(funcall (compile nil (read-from-file pathname))
(read-from-file "base-target-features.lisp-expr")))
(read-from-file "^base-target-features.lisp-expr")))
(customizer-file-name "customize-target-features.lisp")
(customizer (if (probe-file customizer-file-name)
(compile nil
(read-from-file customizer-file-name))
#'identity))
(target-feature-list (funcall customizer default-features))
;; Bind temporarily so that TARGET-FEATUREP and TARGET-PLATFORM-KEYWORD
;; can see the tentative list.
(sb-xc:*features* (funcall customizer default-features))
(gc (find-if (lambda (x) (member x '(:cheneygc :gencgc)))
target-feature-list))
(arch (target-platform-keyword target-feature-list)))
sb-xc:*features*))
(arch (target-platform-keyword)))
;; Win32 conditionally adds :sb-futex in grovel-features.sh
(when (featurep '(:and :sb-thread (:or :linux :freebsd)) target-feature-list)
(pushnew :sb-futex target-feature-list))
(when (featurep '(:and :sb-thread (:not :win32)) target-feature-list)
(push :pauseless-threadstart target-feature-list))
(when (featurep '(:and :sb-thread (:or :darwin :openbsd)) target-feature-list)
(when (target-featurep '(:and :sb-thread (:or :linux :freebsd)))
(pushnew :sb-futex sb-xc:*features*))
(when (target-featurep '(:and :sb-thread (:not :win32)))
(push :pauseless-threadstart sb-xc:*features*))
(when (target-featurep '(:and :sb-thread (:or :darwin :openbsd)))
(push :os-thread-stack target-feature-list))
(when (and (member :x86 target-feature-list)
(member :int4-breakpoints target-feature-list))
(when (target-featurep '(:and :x86 :int4-breakpoints))
;; 0xCE is a perfectly good 32-bit instruction,
;; unlike on x86-64 where it is illegal. It's therefore
;; confusing to allow this feature in a 32-bit build.
;; But it's annoying to have a build script that otherwise works
;; for a native x86/x86-64 build except for needing one change.
;; Just print something and go on with life.
(setq target-feature-list
(remove :int4-breakpoints target-feature-list))
(setq sb-xc:*features* (remove :int4-breakpoints sb-xc:*features*))
(warn "Removed :INT4-BREAKPOINTS from target features"))
(when (or (member :arm64 target-feature-list)
(member :sse4 *shebang-backend-subfeatures*))
(push :round-float target-feature-list))
(when (and (member :arm64 target-feature-list)
(member :darwin target-feature-list))
(push :arm-v8.1 *shebang-backend-subfeatures*))
(when (target-featurep '(:or :arm64 :sse4))
(push :round-float sb-xc:*features*))
(when (target-featurep '(:and :arm64 :darwin))
(push :arm-v8.1 backend-subfeatures))
;; Putting arch and gc choice first is visually convenient, versus
;; having to parse a random place in the line to figure out the value
@ -284,7 +301,7 @@
;; De-duplicate the rest of the symbols because the command line
;; can add redundant --with-mumble options.
(list* arch gc (sort (remove-duplicates
(remove arch (remove gc target-feature-list)))
(remove arch (remove gc sb-xc:*features*)))
#'string<))))
;;; Call for effect of signaling an error if no target picked.
@ -360,7 +377,7 @@
;;; All code depending on this is itself dependent on #+SB-SHOW.
(defvar *cl-snapshot*)
(when (member :sb-show sb-xc:*features*)
(load "src/cold/snapshot.lisp")
(load (find-bootstrap-file "^snapshot"))
(setq *cl-snapshot* (take-snapshot "COMMON-LISP")))
;;;; master list of source files and their properties
@ -427,8 +444,8 @@
(,flags (rest ,stem-and-flags)))
,@body))))
;;; Given a STEM, remap the path component "/{arch}/" to a suitable
;;; target directory.
;;; Given a STEM, remap the path components "/{arch}/" and "/asm-target/"
;;; to suitable directories.
(defun stem-remap-target (stem)
(flet ((try-replacing (this that)
(let ((position (search this stem)))
@ -450,7 +467,7 @@
;;; is not actually implemented in the generic build, however if your build
;;; system does that by itself, then hooray for you)
(defun stem-source-path (stem)
(concatenate 'string (prepend-genfile-path (stem-remap-target stem)) ".lisp"))
(concatenate 'string (find-bootstrap-file (stem-remap-target stem)) ".lisp"))
(compile 'stem-source-path)
;;; Determine the object path for a stem/flags/mode combination.
@ -490,7 +507,7 @@
;; to produce warnings as a bug workaround.
(let ((cl:*features* (cons feature cl:*features*))
(*readtable* *xc-readtable*))
(read-from-file "build-order.lisp-expr" nil))))
(read-from-file "^build-order.lisp-expr" nil))))
(setf *stems-and-flags* (cons build-phase list)))
;; Now check for duplicate stems and bogus flags.
(let ((stems (make-hash-table :test 'equal)))

View file

@ -24,7 +24,7 @@
(declaim (type list sb-xc:*features*))
(defvar sb-xc:*features*)
(defun target-platform-keyword (&optional (features sb-xc:*features*))
(defun target-platform-keyword (&aux (features sb-xc:*features*))
(let ((arch (intersection '(:arm :arm64 :mips :ppc :ppc64 :riscv :sparc :x86 :x86-64)
features)))
(cond ((not arch) (error "No architecture selected"))
@ -32,8 +32,7 @@
(car arch)))
;;; Not necessarily the logical place to define BACKEND-ASM-PACKAGE-NAME,
;;; but a convenient one, because sb-xc:*features* needs to have been
;;; DEFVARed, and because 'chill' loads this and only this file.
;;; but a convenient one.
(defun backend-assembler-target-name ()
(let ((keyword (target-platform-keyword)))
(case keyword
@ -42,23 +41,19 @@
(defun backend-asm-package-name ()
(concatenate 'string "SB-" (string (backend-assembler-target-name)) "-ASM"))
;;; We should never call this with a selector of :HOST any more,
;;; but I'm keeping it in case of emergency.
;;; SB-XC:*FEATURES* might not be bound yet when computing derived features.
(defun featurep (feature &optional (list sb-xc:*features*))
;;; Like the real FEATUREP but using SB-XC:*FEATURES* instead of CL:*FEATURES*
(defun target-featurep (feature)
(etypecase feature
(symbol
(if (string= feature "SBCL")
(error "Testing SBCL as a target feature is obviously bogus")
(member feature list :test #'eq)))
(cons (flet ((subfeature-in-list-p (subfeature)
(featurep subfeature list)))
(ecase (first feature)
(:or (some #'subfeature-in-list-p (rest feature)))
(:and (every #'subfeature-in-list-p (rest feature)))
(:not (destructuring-bind (subexpr) (cdr feature)
(not (subfeature-in-list-p subexpr)))))))))
(compile 'featurep)
(member feature sb-xc:*features* :test #'eq)))
(cons (ecase (first feature)
(:or (some #'target-featurep (rest feature)))
(:and (every #'target-featurep (rest feature)))
(:not (destructuring-bind (subexpr) (cdr feature)
(not (target-featurep subexpr))))))))
(compile 'target-featurep)
(defun read-targ-feature-expr (stream sub-character infix-parameter)
(when infix-parameter
@ -66,7 +61,7 @@
(if (char= (if (let* ((*package* (find-package "KEYWORD"))
(*read-suppress* nil)
(feature (read stream t nil t)))
(featurep feature))
(target-featurep feature))
#\+ #\-)
sub-character)
(read stream t nil t)
@ -87,19 +82,6 @@
t ; non-terminating so that symbols may contain a dollar sign
*xc-readtable*)
;;;; variables like SB-XC:*FEATURES* but different
;;; This variable is declared here (like SB-XC:*FEATURES*) so that
;;; things like chill.lisp work (because the variable has properties
;;; similar to SB-XC:*FEATURES*, and chill.lisp was set up to work
;;; for that). For an explanation of what it really does, look
;;; elsewhere.
;;; FIXME: Can we just assign SB-C:*BACKEND-SUBFEATURES* directly?
;;; (This has nothing whatsoever to do with the so-called "shebang" reader)
(export '*shebang-backend-subfeatures*)
(declaim (type list *shebang-backend-subfeatures*))
(defvar *shebang-backend-subfeatures*)
;;;; string checker, for catching non-portability early
;;; A note about CLISP compatibility:

View file

@ -46,7 +46,7 @@
;;; :trace-file as a flag.
(setf *stems-and-flags*
(let ((*readtable* *xc-readtable*))
(read-from-file "build-order.lisp-expr" nil)))
(read-from-file "^build-order.lisp-expr" nil)))
;;; Don't care about deftransforms that get redefined.
;;; The target condition is defined in 'condition' which is a :not-host file.

View file

@ -127,8 +127,8 @@ sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**))
;;; ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
;;; (declare (optimize (speed 0))))))
;;;
(let ((sources (with-open-file (f (merge-pathnames "../../build-order.lisp-expr"
*load-pathname*))
(defvar *sbclroot* "")
(let ((sources (with-open-file (f (merge-pathnames "build-order.lisp-expr" *load-pathname*))
(read f) ; skip over the make-host-{1,2} input files
(read f)))
(sb-c::*handled-conditions* sb-c::*handled-conditions*))
@ -143,7 +143,8 @@ sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**))
;; a literal (when compiling in the LOAD step)
t))
(output
(compile-file-pathname stem
(compile-file-pathname
(concatenate 'string *sbclroot* stem)
:output-file
(merge-pathnames
(concatenate
@ -170,7 +171,8 @@ sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**))
(safety 2) (speed 2)
(sb-c:insert-step-conditions 0)
(sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)))
(compile-file stem :output-file output)))
(compile-file (concatenate 'string *sbclroot* stem)
:output-file output)))
((nil) output))
(cond ((not output-truename)
(error "COMPILE-FILE of ~S failed." stem))

View file

@ -160,12 +160,9 @@ conditionalization.
|#
;;; The default value of NIL means use only unguarded VOPs. The
;;; initial value is customizeable via
;;; customize-backend-subfeatures.lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *backend-subfeatures*
'#.(sort (copy-list sb-cold:*shebang-backend-subfeatures*) #'string<)))
(declaim (always-bound *backend-subfeatures*))
;;; initial value is customizeable via customize-backend-subfeatures.lisp
(defvar *backend-subfeatures* '#.(sort sb-cold:backend-subfeatures #'string<))
#-sb-xc-host (declaim (always-bound *backend-subfeatures*))
;;; possible *BACKEND-SUBFEATURES* values:
;;;

View file

@ -3563,7 +3563,7 @@ III. initially undefined function references (alphabetically):
;;; the "initial core file" because core files could be created later
;;; by executing SAVE-LISP in a running system, perhaps after we've
;;; added some functionality to the system.)
(defun write-initial-core-file (filename verbose)
(defun write-initial-core-file (filename build-id verbose)
(when verbose
(let ((*print-length* nil)
@ -3588,7 +3588,8 @@ III. initially undefined function references (alphabetically):
;; plus a suffix identifying a certain configuration of the C compiler.
(binding* ((build-id (concatenate
'string
(with-open-file (s "output/build-id.inc") (read s))
(or build-id
(with-open-file (s "output/build-id.inc") (read s)))
(if (member :msan sb-xc:*features*) "-msan" "")))
((nwords padding) (ceiling (length build-id) sb-vm:n-word-bytes)))
(declare (type simple-string build-id))
@ -3651,6 +3652,7 @@ III. initially undefined function references (alphabetically):
;;; MAP-FILE-NAME gets the name of the textual 'cold-sbcl.map' file
(defun sb-cold:genesis (&key object-file-names tls-init
defstruct-descriptions
build-id
core-file-name c-header-dir-name map-file-name
symbol-table-file-name (verbose t))
(declare (ignorable symbol-table-file-name))
@ -3775,7 +3777,7 @@ III. initially undefined function references (alphabetically):
;; target of accidental leftover symbols, not that it wouldn't also be
;; a good idea to clean up package-data-list once in a while.
(dolist (exported-name
(sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
(sb-cold:read-from-file "^common-lisp-exports.lisp-expr"))
(cold-intern (intern exported-name *cl-package*) :access :external))
;; Make LOGICALLY-READONLYIZE no longer a no-op
@ -3878,7 +3880,7 @@ III. initially undefined function references (alphabetically):
(with-open-file (stream map-file-name :direction :output :if-exists :supersede)
(write-map stream)))
(when core-file-name
(write-initial-core-file core-file-name verbose))
(write-initial-core-file core-file-name build-id verbose))
(unless c-header-dir-name
(return-from sb-cold:genesis))
(let ((filename (format nil "~A/Makefile.features" c-header-dir-name)))

View file

@ -9,7 +9,6 @@
("case.pure.lisp" "tests/case-test.lisp")
("chill.test.sh"
"src/cold/chill.lisp"
"src/cold/shebang.lisp"
"package-data-list.lisp-expr")
("clos.impure.lisp"
"contrib/sb-cltl2.fasl"