1 ;;; Do warm init without compiling files.
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
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
)
18 (dolist (symbol (cdr list
))
20 (unintern symbol package
))))
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))
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
))
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:
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
))
69 (unintern symbol package
))))))
73 (defvar *compile-files-p
* nil
)
74 "about to LOAD warm.lisp (with *compile-files-p* = NIL)")
77 (load "src/cold/warm.lisp")
79 ;;; Remove docstrings that snuck in, as will happen with
80 ;;; any file compiled in warm load.
83 (macrolet ((clear-it (place)
87 ;; 1. Functions, macros, special operators
88 (sb-vm::map-allocated-objects
89 (lambda (obj type size
)
90 (declare (ignore size
))
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
)))))))
105 ;; 2. Variables, types, and anything else
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
))))
111 (format t
"~&Removed ~D doc string~:P" count
)))
113 ;; Share identical FUN-INFOs
115 (let ((ht (make-hash-table :test
'equalp
))
117 (sb-int:call-with-each-globaldb-name
119 (binding* ((info (info :function
:info name
) :exit-if-null
)
120 (shared-info (gethash info ht info
)))
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
)))
128 (sb-disassem::!compile-inst-printers
)
130 ;; Unintern no-longer-needed stuff before the possible PURIFY in
131 ;; SAVE-LISP-AND-DIE.
132 #-sb-fluid
(!unintern-init-only-stuff
)
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 (when (sb-kernel:immobile-space-obj-p symbol
)
144 (sb-kernel:set-header-data
145 symbol
(logior (sb-kernel:get-header-data symbol
)
146 (ash 1 sb-vm
::+initial-core-symbol-bit
+)))))
148 ;; A symbol whose INFO slot underwent any kind of manipulation
149 ;; such that it now has neither properties nor globaldb info,
150 ;; can have the slot set back to NIL if it wasn't already.
151 (do-all-symbols (symbol)
152 (when (and (sb-kernel:symbol-info symbol
)
153 (null (sb-kernel:symbol-info-vector symbol
))
154 (null (symbol-plist symbol
)))
155 (setf (sb-kernel:symbol-info symbol
) nil
)))
157 ;; Set doc strings for the standard packages.
159 (setf (documentation (find-package "COMMON-LISP") t
)
160 "public: home of symbols defined by the ANSI language specification"
161 (documentation (find-package "COMMON-LISP-USER") t
)
162 "public: the default package for user code and data"
163 (documentation (find-package "KEYWORD") t
)
164 "public: home of keywords")
166 "done with warm.lisp, about to GC :FULL T")
170 ;;; resetting compilation policy to neutral values in preparation for
171 ;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
172 ;;; SB-C::*POLICY* has file scope)
173 (setq sb-c
::*policy
* (copy-structure sb-c
::**baseline-policy
**))
175 ;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
176 (dolist (rt (list sb-impl
::*standard-readtable
* *debug-readtable
*))
177 (setf (readtable-base-char-preference rt
) :symbols
))
178 ;;; Change the internal constructor's default too.
179 (let ((dsd sb-kernel
::(find 'sb-impl
::%readtable-string-preference
180 (dd-slots (find-defstruct-description 'readtable
))
182 (funcall #'(setf slot-value
) 'character dsd
'sb-kernel
::default
))
184 ;;; Even if /SHOW output was wanted during build, it's probably
185 ;;; not wanted by default after build is complete. (And if it's
186 ;;; wanted, it can easily be turned back on.)
187 #+sb-show
(setf sb-int
:*/show
* nil
)
188 ;;; The system is complete now, all standard functions are
190 ;;; The call to CTYPE-OF-CACHE-CLEAR is probably redundant.
191 ;;; SAVE-LISP-AND-DIE calls DEINIT which calls DROP-ALL-HASH-CACHES.
192 (sb-kernel::ctype-of-cache-clear
)
194 ;;; In case there is xref data for internals, repack it here to
195 ;;; achieve a more compact encoding.
197 ;;; However, repacking changes
198 ;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
199 ;;; the interpretation of xref data written into and loaded from
200 ;;; fasls. Since fasls should be compatible between images originating
201 ;;; from the same SBCL build, REPACK-XREF is of no use after the
202 ;;; target image has been built.
203 #+sb-xref-for-internals
(sb-c::repack-xref
:verbose
1)
204 (fmakunbound 'sb-c
::repack-xref
)
206 #+(or x86 x86-64
) ; Crashes on other platforms still :-(
208 (load "src/code/shaketree")
209 (sb-impl::shake-packages
211 ;; Retain all symbols satisfying this predicate
212 (or (sb-kernel:symbol-info symbol
)
213 (and (boundp symbol
) (not (keywordp symbol
))))))
214 (unintern 'sb-impl
::shake-packages
'sb-impl
))
216 ;;; Lock internal packages
218 (dolist (p (list-all-packages))
219 (unless (member p
(mapcar #'find-package
'("KEYWORD" "CL-USER")))
220 (sb-ext:lock-package p
)))
222 ;;; Clean up stray symbols from the CL-USER package.
223 (with-package-iterator (iter "CL-USER" :internal
:external
)
224 (loop (multiple-value-bind (winp symbol
) (iter)
225 (if winp
(unintern symbol
"CL-USER") (return)))))
227 #+immobile-code
(setq sb-c
::*compile-to-memory-space
* :dynamic
)
228 #+sb-fasteval
(setq sb-ext
:*evaluator-mode
* :interpret
)
229 ;; See comments in 'readtable.lisp'
230 (setf (readtable-base-char-preference *readtable
*) :symbols
)
232 "done with warm.lisp, about to SAVE-LISP-AND-DIE"