Fix critical spelling bug in ALLOCATION-INFORMATION.1
[sbcl.git] / make-target-2-load.lisp
bloba8710b5514a00f991fa0013308685dd603f6ccf1
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
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:
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)
68 (fmakunbound symbol)
69 (unintern symbol package))))))
70 result)
72 (progn
73 (defvar *compile-files-p* nil)
74 "about to LOAD warm.lisp (with *compile-files-p* = NIL)")
76 (progn
77 (load "src/cold/warm.lisp")
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)))
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)))
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.
158 #+sb-doc
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")
168 (sb-ext: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))
181 :key #'dsd-name)))
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
189 ;;; defined.
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 (progn
207 (load "src/code/shaketree")
208 (sb-impl::shake-packages
209 (lambda (symbol)
210 ;; Retain all symbols satisfying this predicate
211 (or (sb-kernel:symbol-info symbol)
212 (and (boundp symbol) (not (keywordp symbol))))))
213 (unintern 'sb-impl::shake-packages 'sb-impl))
215 ;;; Lock internal packages
216 #+sb-package-locks
217 (dolist (p (list-all-packages))
218 (unless (member p (mapcar #'find-package '("KEYWORD" "CL-USER")))
219 (sb-ext:lock-package p)))
221 ;;; Clean up stray symbols from the CL-USER package.
222 (with-package-iterator (iter "CL-USER" :internal :external)
223 (loop (multiple-value-bind (winp symbol) (iter)
224 (if winp (unintern symbol "CL-USER") (return)))))
226 #+immobile-code (setq sb-c::*compile-to-memory-space* :dynamic)
227 #+sb-fasteval (setq sb-ext:*evaluator-mode* :interpret)
228 ;; See comments in 'readtable.lisp'
229 (setf (readtable-base-char-preference *readtable*) :symbols)
231 "done with warm.lisp, about to SAVE-LISP-AND-DIE"