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   ;; Share identical FUN-INFOs
 114   sb-int::
 115   (let ((ht (make-hash-table :test 'equalp))
 116         (old-count 0))
 117     (sb-int:call-with-each-globaldb-name
 118      (lambda (name)
 119        (binding* ((info (info :function :info name) :exit-if-null)
 120                   (shared-info (gethash info ht info)))
 121          (incf old-count)
 122          (if (eq info shared-info)
 123              (setf (gethash info ht) info)
 124            (setf (info :function :info name) shared-info)))))
 125     (format t "~&FUN-INFO: Collapsed ~D -> ~D~%"
 126             old-count (hash-table-count ht)))
 127
 128   (sb-disassem::!compile-inst-printers)
 129
 130   ;; Unintern no-longer-needed stuff before the possible PURIFY in
 131   ;; SAVE-LISP-AND-DIE.
 132   #-sb-fluid (!unintern-init-only-stuff)
 133
 134   ;; Mark interned immobile symbols so that COMPILE-FILE knows
 135   ;; which symbols will always be physically in immobile space.
 136   ;; Due to the possibility of interning a symbol that was allocated in dynamic
 137   ;; space, it's not the case that all interned symbols are immobile.
 138   ;; And we can't promise anything across reload, which makes it impossible
 139   ;; for x86-64 codegen to know which symbols are immediate constants.
 140   ;; Except that symbols which existed at SBCL build time must be.
 141   #+(and immobile-space (not immobile-symbols))
 142   (do-all-symbols (symbol)
 143     (sb-sys:with-pinned-objects (symbol)
 144       (let ((addr (sb-kernel:get-lisp-obj-address symbol)))
 145         (when (<= sb-vm:immobile-space-start addr sb-vm:immobile-space-end)
 146           (sb-kernel:set-header-data
 147            symbol (logior (sb-kernel:get-header-data symbol)
 148                           (ash 1 sb-vm::+initial-core-symbol-bit+)))))))
 149
 150   ;; A symbol whose INFO slot underwent any kind of manipulation
 151   ;; such that it now has neither properties nor globaldb info,
 152   ;; can have the slot set back to NIL if it wasn't already.
 153   (do-all-symbols (symbol)
 154     (when (and (sb-kernel:symbol-info symbol)
 155                (null (sb-kernel:symbol-info-vector symbol))
 156                (null (symbol-plist symbol)))
 157       (setf (sb-kernel:symbol-info symbol) nil)))
 158
 159   ;; Set doc strings for the standard packages.
 160   #+sb-doc
 161   (setf (documentation (find-package "COMMON-LISP") t)
 162         "public: home of symbols defined by the ANSI language specification"
 163         (documentation (find-package "COMMON-LISP-USER") t)
 164         "public: the default package for user code and data"
 165         (documentation (find-package "KEYWORD") t)
 166         "public: home of keywords")
 167
 168   "done with warm.lisp, about to GC :FULL T")
 169
 170 (sb-ext:gc :full t)
 171
 172 ;;; resetting compilation policy to neutral values in preparation for
 173 ;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
 174 ;;; SB-C::*POLICY* has file scope)
 175 (setq sb-c::*policy* (copy-structure sb-c::**baseline-policy**))
 176
 177 ;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
 178 (dolist (rt (list sb-impl::*standard-readtable* *debug-readtable*))
 179   (setf (readtable-base-char-preference rt) :symbols))
 180 ;;; Change the internal constructor's default too.
 181 (let ((dsd sb-kernel::(find 'sb-impl::%readtable-string-preference
 182                             (dd-slots (find-defstruct-description 'readtable))
 183                             :key #'dsd-name)))
 184   (funcall #'(setf slot-value) 'character dsd 'sb-kernel::default))
 185
 186 ;;; Lock internal packages
 187 #+sb-package-locks
 188 (dolist (p (list-all-packages))
 189   (unless (member p (mapcar #'find-package '("KEYWORD" "CL-USER")))
 190     (sb-ext:lock-package p)))
 191
 192 "done with warm.lisp, about to SAVE-LISP-AND-DIE"
 193 ;;; Even if /SHOW output was wanted during build, it's probably
 194 ;;; not wanted by default after build is complete. (And if it's
 195 ;;; wanted, it can easily be turned back on.)
 196 #+sb-show (setf sb-int:*/show* nil)
 197 ;;; The system is complete now, all standard functions are
 198 ;;; defined.
 199 ;;; The call to CTYPE-OF-CACHE-CLEAR is probably redundant.
 200 ;;; SAVE-LISP-AND-DIE calls DEINIT which calls DROP-ALL-HASH-CACHES.
 201 (sb-kernel::ctype-of-cache-clear)
 202 (setq sb-c::*flame-on-necessarily-undefined-thing* t)
 203
 204 ;;; Clean up stray symbols from the CL-USER package.
 205 (with-package-iterator (iter "CL-USER" :internal :external)
 206   (loop (multiple-value-bind (winp symbol) (iter)
 207           (if winp (unintern symbol "CL-USER") (return)))))
 208
 209 ;;; In case there is xref data for internals, repack it here to
 210 ;;; achieve a more compact encoding.
 211 ;;;
 212 ;;; However, repacking changes
 213 ;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
 214 ;;; the interpretation of xref data written into and loaded from
 215 ;;; fasls. Since fasls should be compatible between images originating
 216 ;;; from the same SBCL build, REPACK-XREF is of no use after the
 217 ;;; target image has been built.
 218 #+sb-xref-for-internals (sb-c::repack-xref :verbose 1)
 219 (with-unlocked-packages (#:sb-c)
 220   (fmakunbound 'sb-c::repack-xref))
 221
 222 #+immobile-code (setq sb-c::*compile-to-memory-space* :dynamic)
 223 #+sb-fasteval (setq sb-ext:*evaluator-mode* :interpret)
 224 ;; See comments in 'readtable.lisp'
 225 (setf (readtable-base-char-preference *readtable*) :symbols)