mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
252 lines
13 KiB
Common Lisp
252 lines
13 KiB
Common Lisp
;;;; "warm initialization": initialization which comes after cold init
|
||
|
||
;;;; This software is part of the SBCL system. See the README file for
|
||
;;;; more information.
|
||
;;;;
|
||
;;;; This software is derived from the CMU CL system, which was
|
||
;;;; written at Carnegie Mellon University and released into the
|
||
;;;; public domain. The software is in the public domain and is
|
||
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
|
||
;;;; files for more information.
|
||
|
||
(in-package "COMMON-LISP-USER")
|
||
|
||
;;;; general warm init compilation policy
|
||
|
||
(defvar *objfile-prefix* "obj/from-self/")
|
||
|
||
;;; First things first, bootstrap the WARNING handler.
|
||
sb-kernel::
|
||
(setq **initial-handler-clusters**
|
||
`(((,(find-classoid-cell 'warning) .
|
||
,(named-lambda "MAYBE-MUFFLE" (warning)
|
||
(when (muffle-warning-p warning)
|
||
(muffle-warning warning))))
|
||
(,(find-classoid-cell 'step-condition) . sb-impl::invoke-stepper))))
|
||
;;;; And now a trick: splice those into the oldest *HANDLER-CLUSTERS*
|
||
;;;; which had a placeholder NIL reserved for this purpose.
|
||
(defun splice-handler-clusters ()
|
||
sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**)))
|
||
|
||
;;; Don't use the evaluator, it establishes its own dynamic-extent
|
||
;;; bindings for *handler-clusters*
|
||
(splice-handler-clusters)
|
||
|
||
;;;; Use the same settings as PROCLAIM-TARGET-OPTIMIZATION
|
||
;;;; I could not think of a trivial way to ensure that this stays functionally
|
||
;;;; identical to the corresponding code in 'compile-cold-sbcl'.
|
||
;;;; (One possibility would be to read this form from a lisp-expr file)
|
||
;;;; The intent is that we should generate identical code if a file is moved
|
||
;;;; from the cross-compiled sources to warm-compiled or vice-versa.
|
||
(proclaim '(optimize
|
||
#+sb-show (debug 2)
|
||
(safety 2) (speed 2)
|
||
;; never insert stepper conditions
|
||
(sb-c:insert-step-conditions 0)
|
||
(sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)
|
||
(sb-c:store-coverage-data #+sb-cover-for-internals 3 #-sb-cover-for-internals 0)))
|
||
|
||
(locally
|
||
(declare (notinline find-symbol)) ; don't ask
|
||
(let ((s (find-symbol "*/SHOW*" "SB-INT")))
|
||
;; If you made it this far, chances are that you no longer wish to see
|
||
;; whatever it is that show would have shown. Comment this out if you need.
|
||
(when s (set s nil))))
|
||
|
||
(let ((byte (deref (extern-alien "widetag_lowtag" (array char 256))
|
||
sb-vm:character-widetag)))
|
||
(assert (not (logbitp 7 byte))) ; not a headered object
|
||
(assert (= (logand byte sb-vm:lowtag-mask) sb-vm:list-pointer-lowtag)))
|
||
(gc :full t)
|
||
|
||
;;; Verify that all defstructs with a few exceptions were compiled in a null lexical
|
||
;;; environment. Compiling any call to a structure constructor would like to
|
||
;;; know whether some slots get their default value especially if the default
|
||
;;; is incompatible with the slot type (consider MISSING-ARG, e.g).
|
||
;;; If some initform was compiled in a non-null environment, it might not refer
|
||
;;; to a global function. We'd rather ignore it than incorrectly style-warn.
|
||
(let (result)
|
||
(do-all-symbols (s)
|
||
(let ((dd (sb-kernel:find-defstruct-description s nil)))
|
||
(when (and dd (not (sb-kernel::dd-null-lexenv-p dd)))
|
||
(push (sb-kernel:dd-name dd) result))))
|
||
(assert (null (set-difference
|
||
result
|
||
'(sb-c::conset sb-kernel:args-type
|
||
sb-kernel:array-type
|
||
sb-kernel:character-set-type
|
||
sb-kernel:numeric-union-type
|
||
sb-kernel:member-type)))))
|
||
|
||
;;; Assert that genesis preserved shadowing symbols.
|
||
(let ((p sb-assem::*backend-instruction-set-package*))
|
||
(unless (eq p (find-package "SB-VM"))
|
||
(dolist (expect '("SEGMENT" "MAKE-SEGMENT"))
|
||
(assert (find expect (package-shadowing-symbols p) :test 'string=)))))
|
||
|
||
;;; Verify that compile-time floating-point math matches load-time.
|
||
(defvar *compile-files-p*)
|
||
(when (if (boundp '*compile-files-p*) *compile-files-p* t)
|
||
(with-open-file (output "output/cold-vop-usage.txt" :if-does-not-exist nil)
|
||
(when output
|
||
(setq sb-c::*static-vop-usage-counts* (make-hash-table))
|
||
(loop (let ((line (read-line output nil)))
|
||
(unless line (return))
|
||
(let ((count (read-from-string line))
|
||
(name (read-from-string line t nil :start 8)))
|
||
(setf (gethash name sb-c::*static-vop-usage-counts*) count)))))))
|
||
|
||
;;;; compiling and loading more of the system
|
||
|
||
;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
|
||
;;; COMPILE-PCL, at least some of which we should probably have too:
|
||
;;;
|
||
;;; (with-compilation-unit
|
||
;;; (:optimize '(optimize (debug #+(and (not high-security) small) .5
|
||
;;; #-(or high-security small) 2
|
||
;;; #+high-security 3)
|
||
;;; (speed 2) (safety #+(and (not high-security) small) 0
|
||
;;; #-(or high-security small) 2
|
||
;;; #+high-security 3)
|
||
;;; (inhibit-warnings 2))
|
||
;;; :optimize-interface '(optimize-interface #+(and (not high-security) small)
|
||
;;; (safety 1)
|
||
;;; #+high-security (safety 3))
|
||
;;; :context-declarations
|
||
;;; '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
|
||
;;; security 3)
|
||
;;; (debug #-high-security 1 #+high-s
|
||
;;; ecurity 3))))
|
||
;;; ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
|
||
;;; (declare (optimize (speed 0))))))
|
||
;;;
|
||
(defvar *sbclroot* "")
|
||
(defvar *generated-sources-root* "output/ucd/")
|
||
(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*))
|
||
;; The CONCATENATE transform involves REPLACE which involves UBn-BASH-COPY which involves
|
||
;; SHIFT-TOWARDS-{START|END} which is called with a constant arg. But the interpreter stubs
|
||
;; aren't compiled yet. So in attempting to constant-fold the call, CAREFUL-CALL gets an
|
||
;; undefined-fun error, which is handled fine unless you've broken the handler for undefined-fun
|
||
;; and are trying to debug it in early warm load.
|
||
(declare (notinline concatenate))
|
||
(proclaim '(sb-ext:muffle-conditions compiler-note))
|
||
(flet ((do-srcs (list)
|
||
(dolist (stem list)
|
||
;; Do like SB-COLD::LPNIFY-STEM for consistency, though parse/xlate/unparse
|
||
;; would probably also work. I don't think that's better.
|
||
(let ((fullname (sb-int:logically-readonlyize
|
||
(format nil "SYS:~:@(~A~).LISP" (substitute #\; #\/ stem))
|
||
;; indicate shareable string even if not dumped as
|
||
;; a literal (when compiling in the LOAD step)
|
||
t))
|
||
(output
|
||
(compile-file-pathname
|
||
(concatenate 'string *sbclroot* stem)
|
||
:output-file
|
||
(merge-pathnames
|
||
(concatenate 'string *objfile-prefix*
|
||
(subseq stem 0 (1+ (position #\/ stem :from-end t))))))))
|
||
(flet ((report-recompile-restart (stream)
|
||
(format stream "Recompile file ~S" stem))
|
||
(report-continue-restart (stream)
|
||
(format stream "Continue, using possibly bogus file ~S" output)))
|
||
(tagbody
|
||
retry-compile-file
|
||
(multiple-value-bind (output-truename warnings-p failure-p)
|
||
(ecase (if (boundp '*compile-files-p*) *compile-files-p* t)
|
||
((t)
|
||
(let ((sb-c::*source-namestring* fullname)
|
||
(sb-vm::*eager-tls-assignment* t)
|
||
(sb-c::*force-system-tlab*
|
||
(or (search "src/pcl" stem)
|
||
(search "src/code/aprof" stem)
|
||
(search "src/code/ntrace" stem)))
|
||
(sb-ext:*derive-function-types* t))
|
||
(ensure-directories-exist output)
|
||
;; Like PROCLAIM-TARGET-OPTIMIZATION in 'compile-cold-sbcl'
|
||
;; We should probably stash a copy of the POLICY instance from
|
||
;; make-host-2 in a global var and apply it here.
|
||
(proclaim '(optimize
|
||
(safety 2) (speed 2)
|
||
(sb-c:insert-step-conditions 0)
|
||
(sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)))
|
||
(compile-file (concatenate 'string *sbclroot* stem)
|
||
:output-file output)))
|
||
((nil) output))
|
||
(cond ((not output-truename)
|
||
(error "COMPILE-FILE of ~S failed." stem))
|
||
(failure-p
|
||
(unwind-protect
|
||
(restart-case
|
||
(error "FAILURE-P was set when creating ~S."
|
||
output-truename)
|
||
(recompile ()
|
||
:report report-recompile-restart
|
||
(go retry-compile-file))
|
||
(continue ()
|
||
:report report-continue-restart
|
||
(setf failure-p nil)))
|
||
;; Don't leave failed object files lying around.
|
||
(when (and failure-p (probe-file output-truename))
|
||
(delete-file output-truename)
|
||
(format t "~&deleted ~S~%" output-truename))))
|
||
(warnings-p
|
||
;; Maybe we should escalate more warnings to errors
|
||
;; (see HANDLER-BIND for SIMPLE-WARNING below)
|
||
;; rather than asking what to do here?
|
||
#+(or x86 x86-64) ;; these should complete without warnings
|
||
(cerror "Ignore warnings" "Compile completed with warnings")))
|
||
#+nil (sb-impl::show-hash-cache-statistics)
|
||
(unless (handler-bind
|
||
((sb-kernel:redefinition-with-defgeneric
|
||
#'muffle-warning))
|
||
(let ((sb-c::*source-namestring* fullname))
|
||
;; RISCV is slow, I'd like to see it doing something
|
||
;; rather than appearing to go out to lunch
|
||
(load output-truename :verbose (or #+riscv t))))
|
||
(error "LOAD of ~S failed." output-truename))
|
||
(sb-int:/show "done loading" output-truename))))))))
|
||
|
||
(let ((cl:*compile-print* nil))
|
||
(dolist (group sources)
|
||
;; For the love of god, what are we trying to do here???
|
||
;; It's gone through so many machinations that I can't figure it out.
|
||
;; The goal should be to build warning-free, not layer one
|
||
;; kludge upon another so that it can be allowed not to.
|
||
(handler-bind (((and #+x86-64 warning #-x86-64 simple-warning
|
||
(not sb-kernel:redefinition-warning))
|
||
(lambda (c)
|
||
;; escalate "undefined variable" warnings to errors.
|
||
;; There's no reason to allow them in our code.
|
||
(when (and #-x86-64 ; Don't allow any warnings on x86-64.
|
||
(search "undefined variable"
|
||
(write-to-string c :escape nil)))
|
||
(cerror "Finish warm compile ignoring the problem" c)))))
|
||
(with-compilation-unit ()
|
||
(do-srcs group)))))))
|
||
|
||
(sb-c::dump/restore-interesting-types 'write)
|
||
(when (hash-table-p sb-c::*static-vop-usage-counts*)
|
||
(with-open-file (output (merge-pathnames "warm-vop-usage.txt" *objfile-prefix*)
|
||
:direction :output :if-exists :supersede)
|
||
(let (list)
|
||
(sb-int:dohash ((name vop) sb-c::*backend-parsed-vops*)
|
||
(declare (ignore vop))
|
||
(unless (char= (char (string name) 0) #\!)
|
||
(push (cons (gethash name sb-c::*static-vop-usage-counts* 0) name) list)))
|
||
(dolist (cell (sort list #'> :key #'car))
|
||
(format output "~7d ~s~%" (car cell) (cdr cell))))))
|
||
|
||
(when (and (sb-sys:find-dynamic-foreign-symbol-address "tot_gc_nsec")
|
||
(zerop (extern-alien "lisp_startup_options" char)))
|
||
(let* ((run-sec (/ (get-internal-real-time) internal-time-units-per-second))
|
||
(gc-nsec (extern-alien "tot_gc_nsec" unsigned))
|
||
(gc-msec (/ (float gc-nsec) 1000000)))
|
||
(format t "~&Done with warm.lisp. INTERNAL-REAL-TIME=~Fs~@[, GC=~Fms (~,1,2f%)~]~%"
|
||
run-sec
|
||
(if (plusp gc-msec) gc-msec) ; timing wasn't enabled if this is 0
|
||
(/ gc-msec (* 1000 run-sec)))))
|