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