make-target-2-load.lisp

   1 ;;; Do warm init without compiling files.
   2
   3 ;;; There's a fair amount of machinery which is needed only at cold
   4 ;;; init time, and should be discarded before freezing the final
   5 ;;; system. We discard it by uninterning the associated symbols.
   6 ;;; Rather than using a special table of symbols to be uninterned,
   7 ;;; which might be tedious to maintain, instead we use a hack:
   8 ;;; anything whose name matches a magic character pattern is
   9 ;;; uninterned.
  10 ;;; Additionally, you can specify an arbitrary way to destroy
  11 ;;; random bootstrap stuff on per-package basis.
  12 (defun !unintern-init-only-stuff (&aux result)
  13   (dolist (package (list-all-packages))
  14     (sb-int:binding* ((s (find-symbol "!UNINTERN-SYMBOLS" package)
  15                          :exit-if-null)
  16                       (list (funcall s))
  17                       (package (car list)))
  18       (dolist (symbol (cdr list))
  19         (fmakunbound symbol)
  20         (unintern symbol package))))
  21   sb-kernel::
  22   (flet ((uninternable-p (symbol)
  23            (let ((name (symbol-name symbol)))
  24              (or (and (>= (length name) 1) (char= (char name 0) #\!))
  25                  (and (>= (length name) 2) (string= name "*!" :end1 2))
  26                  (memq symbol
  27                        '(sb-c::sb!pcl sb-c::sb!impl sb-c::sb!kernel
  28                          sb-c::sb!c sb-c::sb-int))))))
  29     ;; A structure constructor name, in particular !MAKE-SAETP,
  30     ;; can't be uninterned if referenced by a defstruct-description.
  31     ;; So loop over all structure classoids and clobber any
  32     ;; symbol that should be uninternable.
  33     (maphash (lambda (classoid layout)
  34                (when (structure-classoid-p classoid)
  35                  (let ((dd (layout-info layout)))
  36                    (setf (dd-constructors dd)
  37                          (delete-if (lambda (x)
  38                                       (and (consp x) (uninternable-p (car x))))
  39                                     (dd-constructors dd))))))
  40              (classoid-subclasses (find-classoid t)))
  41     ;; Todo: perform one pass, then a full GC, then a final pass to confirm
  42     ;; it worked. It shoud be an error if any uninternable symbols remain,
  43     ;; but at present there are about 13 other "!" symbols with referers.
  44     (with-package-iterator (iter (list-all-packages) :internal :external)
  45       (loop (multiple-value-bind (winp symbol accessibility package) (iter)
  46               (declare (ignore accessibility))
  47               (unless winp
  48                 (return))
  49               (when (uninternable-p symbol)
  50                 ;; Uninternable symbols which are referenced by other stuff
  51                 ;; can't disappear from the image, but we don't need to preserve
  52                 ;; their functions, so FMAKUNBOUND them. This doesn't have
  53                 ;; the intended effect if the function shares a code-component
  54                 ;; with non-cold-init lambdas. Though the cold-init function is
  55                 ;; never called post-build, it is not discarded. Also, I suspect
  56                 ;; that the following loop should print nothing, but it does:
  57 #|
  58                 (sb-vm::map-allocated-objects
  59                   (lambda (obj type size)
  60                     (declare (ignore size))
  61                     (when (= type sb-vm:code-header-widetag)
  62                       (let ((name (sb-c::debug-info-name
  63                                    (sb-kernel:%code-debug-info obj))))
  64                         (when (and (stringp name) (search "COLD-INIT-FORMS" name))
  65                           (print obj)))))
  66                   :dynamic)
  67 |#
  68                 (fmakunbound symbol)
  69                 (unintern symbol package))))))
  70   result)
  71
  72 (progn
  73   (defvar *compile-files-p* nil)
  74   "about to LOAD warm.lisp (with *compile-files-p* = NIL)")
  75
  76 (progn
  77   (load "src/cold/warm.lisp")
  78
  79   ;;; Remove docstrings that snuck in, as will happen with
  80   ;;; any file compiled in warm load.
  81   #-sb-doc
  82   (let ((count 0))
  83     (macrolet ((clear-it (place)
  84                  `(when ,place
  85                     (setf ,place nil)
  86                     (incf count))))
  87       ;; 1. Functions, macros, special operators
  88       (sb-vm::map-allocated-objects
  89        (lambda (obj type size)
  90          (declare (ignore size))
  91          (case type
  92           (#.sb-vm:code-header-widetag
  93            (dotimes (i (sb-kernel:code-n-entries obj))
  94              (let ((f (sb-kernel:%code-entry-point obj i)))
  95                (clear-it (sb-kernel:%simple-fun-doc f)))))
  96           (#.sb-vm:instance-widetag
  97            (when (typep obj 'class)
  98              (when (slot-boundp obj 'sb-pcl::%documentation)
  99                (clear-it (slot-value obj 'sb-pcl::%documentation)))))
 100           (#.sb-vm:funcallable-instance-widetag
 101            (when (typep obj 'standard-generic-function)
 102              (when (slot-boundp obj 'sb-pcl::%documentation)
 103                (clear-it (slot-value obj 'sb-pcl::%documentation)))))))
 104        :all)
 105       ;; 2. Variables, types, and anything else
 106       (do-all-symbols (s)
 107         (dolist (category '(:variable :type :typed-structure :setf))
 108           (clear-it (sb-int:info category :documentation s)))
 109         (clear-it (sb-int:info :random-documentation :stuff s))))
 110     (when (plusp count)
 111       (format t "~&Removed ~D doc string~:P" count)))
 112
 113   ;; Remove source forms of compiled-to-memory lambda expressions.
 114   ;; The disassembler is the major culprit for retention of these.
 115   (sb-vm::map-allocated-objects
 116    (lambda (obj type size)
 117      (declare (ignore size))
 118      (when (typep obj 'sb-c::debug-source)
 119        (unless (sb-c::debug-source-namestring obj)
 120          (setf (sb-c::debug-source-form obj) nil))))
 121    :all)
 122
 123   ;; Unintern no-longer-needed stuff before the possible PURIFY in
 124   ;; SAVE-LISP-AND-DIE.
 125   #-sb-fluid (!unintern-init-only-stuff)
 126
 127   ;; Mark interned immobile symbols so that COMPILE-FILE knows
 128   ;; which symbols will always be physically in immobile space.
 129   ;; Due to the possibility of interning a symbol that was allocated in dynamic
 130   ;; space, it's not the case that all interned symbols are immobile.
 131   ;; And we can't promise anything across reload, which makes it impossible
 132   ;; for x86-64 codegen to know which symbols are immediate constants.
 133   ;; Except that symbols which existed at SBCL build time must be.
 134   #+(and immobile-space (not immobile-symbols))
 135   (do-all-symbols (symbol)
 136     (when (sb-kernel:immobile-space-obj-p symbol)
 137       (sb-kernel:set-header-data
 138            symbol (logior (sb-kernel:get-header-data symbol)
 139                           (ash 1 sb-vm::+initial-core-symbol-bit+)))))
 140
 141   ;; A symbol whose INFO slot underwent any kind of manipulation
 142   ;; such that it now has neither properties nor globaldb info,
 143   ;; can have the slot set back to NIL if it wasn't already.
 144   (do-all-symbols (symbol)
 145     (when (and (sb-kernel:symbol-info symbol)
 146                (null (sb-kernel:symbol-info-vector symbol))
 147                (null (symbol-plist symbol)))
 148       (setf (sb-kernel:symbol-info symbol) nil)))
 149
 150   ;; Set doc strings for the standard packages.
 151   #+sb-doc
 152   (setf (documentation (find-package "COMMON-LISP") t)
 153         "public: home of symbols defined by the ANSI language specification"
 154         (documentation (find-package "COMMON-LISP-USER") t)
 155         "public: the default package for user code and data"
 156         (documentation (find-package "KEYWORD") t)
 157         "public: home of keywords")
 158
 159   "done with warm.lisp, about to GC :FULL T")
 160
 161 (sb-ext:gc :full t)
 162
 163 ;;; resetting compilation policy to neutral values in preparation for
 164 ;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
 165 ;;; SB-C::*POLICY* has file scope)
 166 (setq sb-c::*policy* (copy-structure sb-c::**baseline-policy**))
 167
 168 ;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
 169 (dolist (rt (list sb-impl::*standard-readtable* *debug-readtable*))
 170   (setf (readtable-base-char-preference rt) :symbols))
 171 ;;; Change the internal constructor's default too.
 172 (let ((dsd sb-kernel::(find 'sb-impl::%readtable-string-preference
 173                             (dd-slots (find-defstruct-description 'readtable))
 174                             :key #'dsd-name)))
 175   (funcall #'(setf slot-value) 'character dsd 'sb-kernel::default))
 176
 177 ;;; Even if /SHOW output was wanted during build, it's probably
 178 ;;; not wanted by default after build is complete. (And if it's
 179 ;;; wanted, it can easily be turned back on.)
 180 #+sb-show (setf sb-int:*/show* nil)
 181 ;;; The system is complete now, all standard functions are
 182 ;;; defined.
 183 ;;; The call to CTYPE-OF-CACHE-CLEAR is probably redundant.
 184 ;;; SAVE-LISP-AND-DIE calls DEINIT which calls DROP-ALL-HASH-CACHES.
 185 (sb-kernel::ctype-of-cache-clear)
 186
 187 ;;; In case there is xref data for internals, repack it here to
 188 ;;; achieve a more compact encoding.
 189 ;;;
 190 ;;; However, repacking changes
 191 ;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
 192 ;;; the interpretation of xref data written into and loaded from
 193 ;;; fasls. Since fasls should be compatible between images originating
 194 ;;; from the same SBCL build, REPACK-XREF is of no use after the
 195 ;;; target image has been built.
 196 #+sb-xref-for-internals (sb-c::repack-xref :verbose 1)
 197 (fmakunbound 'sb-c::repack-xref)
 198
 199 (progn
 200   (load "src/code/shaketree")
 201   (sb-impl::shake-packages
 202    (lambda (symbol)
 203      ;; Retain all symbols satisfying this predicate
 204      (or (sb-kernel:symbol-info symbol)
 205          (and (boundp symbol) (not (keywordp symbol))))))
 206   (unintern 'sb-impl::shake-packages 'sb-impl))
 207
 208 ;;; Use historical (stupid) behavior for storing pathname namestrings
 209 ;;; in fasls.
 210 (setq sb-c::*name-context-file-path-selector* 'truename)
 211
 212 ;;; Lock internal packages
 213 #+sb-package-locks
 214 (dolist (p (list-all-packages))
 215   (unless (member p (mapcar #'find-package '("KEYWORD" "CL-USER")))
 216     (sb-ext:lock-package p)))
 217
 218 ;;; Clean up stray symbols from the CL-USER package.
 219 (with-package-iterator (iter "CL-USER" :internal :external)
 220   (loop (multiple-value-bind (winp symbol) (iter)
 221           (if winp (unintern symbol "CL-USER") (return)))))
 222
 223 #+immobile-code (setq sb-c::*compile-to-memory-space* :dynamic)
 224 #+sb-fasteval (setq sb-ext:*evaluator-mode* :interpret)
 225 ;; See comments in 'readtable.lisp'
 226 (setf (readtable-base-char-preference *readtable*) :symbols)
 227
 228 "done with warm.lisp, about to SAVE-LISP-AND-DIE"