src/cold/warm.lisp

   1 ;;;; "warm initialization": initialization which comes after cold init
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "COMMON-LISP-USER")
  13 \f
  14 ;;;; general warm init compilation policy
  15
  16 (defvar *objfile-prefix* "obj/from-self/")
  17
  18 ;;; First things first, bootstrap the WARNING handler.
  19 sb-kernel::
  20 (setq **initial-handler-clusters**
  21       `(((,(find-classoid-cell 'warning) .
  22            ,(named-lambda "MAYBE-MUFFLE" (warning)
  23               (when (muffle-warning-p warning)
  24                 (muffle-warning warning))))
  25          (,(find-classoid-cell 'step-condition) . sb-impl::invoke-stepper))))
  26 ;;;; And now a trick: splice those into the oldest *HANDLER-CLUSTERS*
  27 ;;;; which had a placeholder NIL reserved for this purpose.
  28 (defun splice-handler-clusters ()
  29   sb-kernel::(rplaca (last *handler-clusters*) (car **initial-handler-clusters**)))
  30
  31 ;;; Don't use the evaluator, it establishes its own dynamic-extent
  32 ;;; bindings for *handler-clusters*
  33 (splice-handler-clusters)
  34
  35 ;;;; Use the same settings as PROCLAIM-TARGET-OPTIMIZATION
  36 ;;;; I could not think of a trivial way to ensure that this stays functionally
  37 ;;;; identical to the corresponding code in 'compile-cold-sbcl'.
  38 ;;;; (One possibility would be to read this form from a lisp-expr file)
  39 ;;;; The intent is that we should generate identical code if a file is moved
  40 ;;;; from the cross-compiled sources to warm-compiled or vice-versa.
  41 (proclaim '(optimize
  42             #+sb-show (debug 2)
  43             (safety 2) (speed 2)
  44             ;; never insert stepper conditions
  45             (sb-c:insert-step-conditions 0)
  46             (sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)))
  47
  48 (locally
  49     (declare (notinline find-symbol)) ; don't ask
  50   (let ((s (find-symbol "*/SHOW*" "SB-INT")))
  51   ;; If you made it this far, chances are that you no longer wish to see
  52   ;; whatever it is that show would have shown. Comment this out if you need.
  53     (when s (set s nil))))
  54
  55 (let ((byte (deref (extern-alien "widetag_lowtag" (array char 256))
  56                    sb-vm:character-widetag)))
  57   (assert (not (logbitp 7 byte))) ; not a headered object
  58   (assert (= (logand byte sb-vm:lowtag-mask) sb-vm:list-pointer-lowtag)))
  59 (gc :full t)
  60
  61 ;;; Verify that all defstructs with a few exceptions were compiled in a null lexical
  62 ;;; environment. Compiling any call to a structure constructor would like to
  63 ;;; know whether some slots get their default value especially if the default
  64 ;;; is incompatible with the slot type (consider MISSING-ARG, e.g).
  65 ;;; If some initform was compiled in a non-null environment, it might not refer
  66 ;;; to a global function. We'd rather ignore it than incorrectly style-warn.
  67 (let (result)
  68   (do-all-symbols (s)
  69     (let ((dd (sb-kernel:find-defstruct-description s nil)))
  70       (when (and dd (not (sb-kernel::dd-null-lexenv-p dd)))
  71         (push (sb-kernel:dd-name dd) result))))
  72   (assert (null (set-difference
  73                  result
  74                  '(sb-c::conset sb-kernel:args-type
  75                    sb-kernel:array-type
  76                    sb-kernel:character-set-type
  77                    sb-kernel:numeric-type
  78                    sb-kernel:member-type)))))
  79
  80 ;;; Assert that genesis preserved shadowing symbols.
  81 (let ((p sb-assem::*backend-instruction-set-package*))
  82   (unless (eq p (find-package "SB-VM"))
  83     (dolist (expect '("SEGMENT" "MAKE-SEGMENT"))
  84       (assert (find expect (package-shadowing-symbols p) :test 'string=)))))
  85
  86 ;;; Verify that compile-time floating-point math matches load-time.
  87 (defvar *compile-files-p*)
  88 (when (if (boundp '*compile-files-p*) *compile-files-p* t)
  89   (with-open-file (output "output/cold-vop-usage.txt" :if-does-not-exist nil)
  90     (when output
  91       (setq sb-c::*static-vop-usage-counts* (make-hash-table))
  92       (loop (let ((line (read-line output nil)))
  93               (unless line (return))
  94               (let ((count (read-from-string line))
  95                     (name (read-from-string line t nil :start 8)))
  96                 (setf (gethash name sb-c::*static-vop-usage-counts*) count)))))))
  97 \f
  98 ;;;; compiling and loading more of the system
  99
 100 ;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
 101 ;;; COMPILE-PCL, at least some of which we should probably have too:
 102 ;;;
 103 ;;; (with-compilation-unit
 104 ;;;     (:optimize '(optimize (debug #+(and (not high-security) small) .5
 105 ;;;                               #-(or high-security small) 2
 106 ;;;                               #+high-security 3)
 107 ;;;                        (speed 2) (safety #+(and (not high-security) small) 0
 108 ;;;                                          #-(or high-security small) 2
 109 ;;;                                          #+high-security 3)
 110 ;;;                        (inhibit-warnings 2))
 111 ;;;      :optimize-interface '(optimize-interface #+(and (not high-security) small)
 112 ;;; (safety 1)
 113 ;;;                                            #+high-security (safety 3))
 114 ;;;      :context-declarations
 115 ;;;      '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
 116 ;;; security 3)
 117 ;;;                                             (debug #-high-security 1 #+high-s
 118 ;;; ecurity 3))))
 119 ;;;     ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
 120 ;;;     (declare (optimize (speed 0))))))
 121 ;;;
 122 (defvar *sbclroot* "")
 123 (defvar *generated-sources-root* "output/ucd/")
 124 (let ((sources (with-open-file (f (merge-pathnames "build-order.lisp-expr" *load-pathname*))
 125                  (read f) ; skip over the make-host-{1,2} input files
 126                  (read f)))
 127       (sb-c::*handled-conditions* sb-c::*handled-conditions*))
 128  ;; The CONCATENATE transform involves REPLACE which involves UBn-BASH-COPY which involves
 129  ;; SHIFT-TOWARDS-{START|END} which is called with a constant arg. But the interpreter stubs
 130  ;; aren't compiled yet. So in attempting to constant-fold the call, CAREFUL-CALL gets an
 131  ;; undefined-fun error, which is handled fine unless you've broken the handler for undefined-fun
 132  ;; and are trying to debug it in early warm load.
 133  (declare (notinline concatenate))
 134  (proclaim '(sb-ext:muffle-conditions compiler-note))
 135  (flet ((do-srcs (list)
 136          (dolist (stem list)
 137           ;; Do like SB-COLD::LPNIFY-STEM for consistency, though parse/xlate/unparse
 138           ;; would probably also work. I don't think that's better.
 139           (let ((fullname (sb-int:logically-readonlyize
 140                            (format nil "SYS:~:@(~A~).LISP" (substitute #\; #\/ stem))
 141                            ;; indicate shareable string even if not dumped as
 142                            ;; a literal (when compiling in the LOAD step)
 143                            t))
 144                 (output
 145                   (compile-file-pathname
 146                    (concatenate 'string *sbclroot* stem)
 147                    :output-file
 148                    (merge-pathnames
 149                     (concatenate 'string *objfile-prefix*
 150                      (subseq stem 0 (1+ (position #\/ stem :from-end t))))))))
 151            (flet ((report-recompile-restart (stream)
 152                     (format stream "Recompile file ~S" stem))
 153                   (report-continue-restart (stream)
 154                     (format stream "Continue, using possibly bogus file ~S" output)))
 155              (tagbody
 156               retry-compile-file
 157                 (multiple-value-bind (output-truename warnings-p failure-p)
 158                     (ecase (if (boundp '*compile-files-p*) *compile-files-p* t)
 159                      ((t)
 160                       (let ((sb-c::*source-namestring* fullname)
 161                             (sb-c::*force-system-tlab*
 162                              (or (search "src/pcl" stem)
 163                                  (search "src/code/aprof" stem)))
 164                             (sb-ext:*derive-function-types*
 165                               (unless (search "/pcl/" stem)
 166                                 t)))
 167                         (ensure-directories-exist output)
 168                         ;; Like PROCLAIM-TARGET-OPTIMIZATION in 'compile-cold-sbcl'
 169                         ;; We should probably stash a copy of the POLICY instance from
 170                         ;; make-host-2 in a global var and apply it here.
 171                         (proclaim '(optimize
 172                                     (safety 2) (speed 2)
 173                                     (sb-c:insert-step-conditions 0)
 174                                     (sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)))
 175                         (compile-file (concatenate 'string *sbclroot* stem)
 176                                       :output-file output)))
 177                      ((nil) output))
 178                   (cond ((not output-truename)
 179                          (error "COMPILE-FILE of ~S failed." stem))
 180                         (failure-p
 181                          (unwind-protect
 182                               (restart-case
 183                                   (error "FAILURE-P was set when creating ~S."
 184                                          output-truename)
 185                                 (recompile ()
 186                                   :report report-recompile-restart
 187                                   (go retry-compile-file))
 188                                 (continue ()
 189                                   :report report-continue-restart
 190                                   (setf failure-p nil)))
 191                            ;; Don't leave failed object files lying around.
 192                            (when (and failure-p (probe-file output-truename))
 193                                  (delete-file output-truename)
 194                                  (format t "~&deleted ~S~%" output-truename))))
 195                         (warnings-p
 196                          ;; Maybe we should escalate more warnings to errors
 197                          ;; (see HANDLER-BIND for SIMPLE-WARNING below)
 198                          ;; rather than asking what to do here?
 199                          #+(or x86 x86-64) ;; these should complete without warnings
 200                          (cerror "Ignore warnings" "Compile completed with warnings")))
 201                   #+nil (sb-impl::show-hash-cache-statistics)
 202                   (unless (handler-bind
 203                               ((sb-kernel:redefinition-with-defgeneric
 204                                 #'muffle-warning))
 205                             (let ((sb-c::*source-namestring* fullname))
 206                               ;; RISCV is slow, I'd like to see it doing something
 207                               ;; rather than appearing to go out to lunch
 208                               (load output-truename :verbose (or #+riscv t))))
 209                     (error "LOAD of ~S failed." output-truename))
 210                   (sb-int:/show "done loading" output-truename))))))))
 211
 212   (let ((cl:*compile-print* nil))
 213     (dolist (group sources)
 214       ;; For the love of god, what are we trying to do here???
 215       ;; It's gone through so many machinations that I can't figure it out.
 216       ;; The goal should be to build warning-free, not layer one
 217       ;; kludge upon another so that it can be allowed not to.
 218       (handler-bind (((and #+x86-64 warning #-x86-64 simple-warning
 219                            (not sb-kernel:redefinition-warning))
 220                       (lambda (c)
 221                         ;; escalate "undefined variable" warnings to errors.
 222                         ;; There's no reason to allow them in our code.
 223                         (when (and #-x86-64 ; Don't allow any warnings on x86-64.
 224                                    (search "undefined variable"
 225                                            (write-to-string c :escape nil)))
 226                           (cerror "Finish warm compile ignoring the problem" c)))))
 227         (with-compilation-unit ()
 228           (do-srcs group)))))))
 229
 230 (sb-c::dump/restore-interesting-types 'write)
 231 (when (hash-table-p sb-c::*static-vop-usage-counts*)
 232   (with-open-file (output (merge-pathnames "warm-vop-usage.txt" *objfile-prefix*)
 233                           :direction :output :if-exists :supersede)
 234     (let (list)
 235       (sb-int:dohash ((name vop) sb-c::*backend-parsed-vops*)
 236         (declare (ignore vop))
 237         (unless (char= (char (string name) 0) #\!)
 238           (push (cons (gethash name sb-c::*static-vop-usage-counts* 0) name) list)))
 239       (dolist (cell (sort list #'> :key #'car))
 240         (format output "~7d ~s~%" (car cell) (cdr cell))))))
 241
 242 (when (sb-sys:find-dynamic-foreign-symbol-address "tot_gc_nsec")
 243   (let* ((run-sec (/ (get-internal-real-time) internal-time-units-per-second))
 244          (gc-nsec (extern-alien "tot_gc_nsec" unsigned))
 245          (gc-msec (/ (float gc-nsec) 1000000)))
 246     (format t "~&Done with warm.lisp. INTERNAL-REAL-TIME=~Fs~@[, GC=~Fms (~,1,2f%)~]~%"
 247             run-sec
 248             (if (plusp gc-msec) gc-msec) ; timing wasn't enabled if this is 0
 249             (/ gc-msec (* 1000 run-sec)))))