1 ;;; Do warm init without compiling files.
3 ;;; Get back to a reasonable state where all of the compiler works,
4 ;;; as does SB-VM:HEXDUMP and MAP-ALLOCATED-OBJECTS, etc.
5 ;;; before trying to define any more functions.
6 (defvar *compile-files-p
* nil
)
7 (load (merge-pathnames "src/cold/warm.lisp" *load-pathname
*))
9 ;; sb-xref-for-internals is actively harmful to tree-shaking.
10 ;; Remove some symbols to make the hide-packages test pass.
11 #+sb-xref-for-internals
13 (fmakunbound 'sb-kernel
::type-class-fun-slot
)
14 (fmakunbound 'sb-kernel
::new-ctype
))
16 (sb-impl::!recompile-globaldb-checkfuns
)
18 ;;; Users don't want to know if there are multiple TLABs per se, but they do want
19 ;;; to know if NEW-ARENA returns an arena, so give them a sensible feature name.
20 #+system-tlabs
(push :arena-allocator
*features
*)
22 ;;; Remove symbols from CL:*FEATURES* that should not be exposed to users.
23 (export 'sb-impl
::+internal-features
+ 'sb-impl
)
24 (let* ((non-target-features
26 ;; FIXME: I suspect that this list should be changed to its inverse-
27 ;; features that _SHOULD_ go into SB-IMPL:+INTERNAL-FEATURES+ and
28 ;; comments about the reasoning behind each, rather than features to
29 ;; discard and reasons they're not needed. The default assumption should be
30 ;; to drop any build-time feature that lacks a rationale to preserve it.
32 ;; READ-FROM-STRING prevents making references to
33 ;; all these keywords from the source form itself.
35 (;; :SB-AFTER-XC-CORE is essentially an option flag to make-host-2
37 ;; CONS-PROFILING sets the initial compiler policy which persists
38 ;; into the default baseline policy. It has no relevance post-build
39 ;; in as much as policy can be changed later arbitrarily.
41 ;; Used by nothing after compiling 'target-thread.lisp' or 'thread.c'
42 :SB-FUTEX :OS-THREAD-STACK
43 ;; These affect the BREAK instruction emitter, but the C code is able
44 ;; to handle anything, and post-build we don't care which it is.
45 :UD2-BREAKPOINTS :INT4-BREAKPOINTS
46 ;; Uses of OS-PROVIDES-DLOPEN and -DLADDR are confined to src/code/foreign.lisp
47 :OS-PROVIDES-DLOPEN :OS-PROVIDES-DLADDR
48 ;; more-or-less confined to serve-event, except for a test which now
49 ;; detects whether COMPUTE-POLLFDS is defined and therefore testable.
51 ;; Silly feature we add in because additive features are more sensible
52 ;; than subtractive ones. So you opt out, not in, to having *LOAD-TRUENAME*
54 :ANSI-COMPLIANT-LOAD-TRUENAME
55 ;; The final batch of symbols is strictly for C. The LISP_FEATURE_
56 ;; prefix on the corresponding #define is unfortunate.
57 :GCC-TLS :USE-SYS-MMAP
58 ;;; Enforce using of posix semaphores on Darwin instead of dispatch.
59 :USE-DARWIN-POSIX-SEMAPHORES
60 ;; only for 'src/runtime/wrap.h'
61 :OS-PROVIDES-BLKSIZE-T
62 ;; only for src/runtime/run-program.c
63 :OS-PROVIDES-CLOSE-RANGE-WRAPPER)"))
66 sb-impl
::!sbcl-architecture
68 (:COMMON-LISP :SBCL :ANSI-CL :IEEE-FLOATING-POINT
69 :64-BIT ; choice of word size. 32-bit if absent
70 :BIG-ENDIAN :LITTLE-ENDIAN ; endianness: pick one and only one
71 :BSD :UNIX :LINUX :WIN32 :DARWIN :SUNOS :ANDROID ; OS: pick one or more
72 :FREEBSD :GNU-KFREEBSD :OPENBSD :NETBSD :DRAGONFLY :HAIKU
73 :MACH-O :ELF ; obj file format: pick zero or one
74 ;; I would argue that this should not be exposed,
75 ;; but I would also anticipate blowback from removing it.
76 :GENCGC :MARK-REGION-GC ; GC: pick one and only one
77 :ARENA-ALLOCATOR :ALLOCATION-SIZE-HISTOGRAM
78 ;; Can't use s-l-a-d :compression safely without it
80 ;; Features that are also in *FEATURES-POTENTIALLY-AFFECTING-FASL-FORMAT*
81 ;; and would probably mess up something if made non-public,
82 ;; though I don't think they should all be public.
85 :SB-THREAD :SB-UNICODE
86 ;; Things which (I think) at least one person has requested be kept around
88 ;; We keep the :SB-PACKAGE-LOCKS feature despite it no longer
89 ;; affecting the build. (It's not a choice any more)
91 ;; unsure, I think this is for end-user consumption,
92 ;; though every release of SBCL since eons ago has had local nicknames.
93 :PACKAGE-LOCAL-NICKNAMES
94 ;; Developer mode features. A release build will never have them,
95 ;; hence it makes no difference whether they're public or not.
96 :SB-DEVEL :SB-DEVEL-LOCK-PACKAGES)")))
98 (append non-target-features public-features
)))
99 (defconstant sb-impl
:+internal-features
+
100 ;;; Well, who would have guessed that our internal features list would nicely
101 ;;; repair damage induced by ASDF, namely: ASDF removes features when loaded.
102 ;;; Take a look at (DEFUN DETECT-OS) in uiop.lisp if you don't believe it,
103 ;;; and watch it in action after (require "ASDF") -
106 ;;; (:X86-64 :64-BIT :ANSI-CL :COMMON-LISP :ELF :GENCGC :HAIKU :IEEE-FLOATING-POINT
107 ;;; :LITTLE-ENDIAN :PACKAGE-LOCAL-NICKNAMES :SB-LDB
108 ;;; :SB-PACKAGE-LOCKS :SB-UNICODE :SBCL :UNIX)
110 ;;; * (require :asdf)
111 ;;; ("ASDF" "asdf" "UIOP" "uiop")
113 ;;; (:ASDF3.3 :ASDF3.2 :ASDF3.1 :ASDF3 :ASDF2 :ASDF :OS-UNIX
114 ;;; :NON-BASE-CHARS-EXIST-P :ASDF-UNICODE :X86-64 :64-BIT :ANSI-CL :COMMON-LISP
115 ;;; :ELF :GENCGC :IEEE-FLOATING-POINT :LITTLE-ENDIAN :PACKAGE-LOCAL-NICKNAMES
116 ;;; :SB-LDB :SB-PACKAGE-LOCKS :SB-UNICODE :SBCL :UNIX)
118 ;;; So, what the heck happened to :HAIKU? It's gone.
119 ;;; Well this is pure evil. Just madness.
120 ;;; However, by stashing an extra copy of :HAIKU in the internal feature list,
121 ;;; we can stuff it back in because our contrib builder first loads ASDF
122 ;;; and then rebinds *FEATURES* with the union of the internal ones.
123 (append #+haiku
'(:haiku
)
124 (remove-if (lambda (x) (member x removable-features
)) *features
*)))
125 (setq *features
* (remove-if-not (lambda (x) (member x public-features
))
128 ;;; There's a fair amount of machinery which is needed only at cold
129 ;;; init time, and should be discarded before freezing the final
130 ;;; system. We discard it by uninterning the associated symbols.
131 ;;; Rather than using a special table of symbols to be uninterned,
132 ;;; which might be tedious to maintain, instead we use a hack:
133 ;;; anything whose name matches a magic character pattern is
135 ;;; Additionally, you can specify an arbitrary way to destroy
136 ;;; random bootstrap stuff on per-package basis.
137 (defun !unintern-init-only-stuff
(&aux result
)
138 (dolist (package (list-all-packages))
139 (sb-int:awhen
(find-symbol "!REMOVE-BOOTSTRAP-SYMBOLS" package
)
140 (funcall sb-int
:it
)))
141 (dolist (list sb-int
:*!removable-symbols
*)
142 (let ((package (find-package (car list
))))
143 (dolist (symbol (cdr list
))
145 (unintern symbol package
))))
147 (flet ((uninternable-p (symbol)
148 (let ((name (symbol-name symbol
)))
149 (or (and (>= (length name
) 1) (char= (char name
0) #\
!))
150 (and (>= (length name
) 2) (string= name
"*!" :end1
2))
152 '(sb-c::sb-pcl sb-c
::sb-impl sb-c
::sb-kernel
153 sb-c
::sb-c sb-c
::sb-int
))))))
154 ;; Delete bootstrap-only vops
155 (flet ((drop-keys (table)
156 (loop for symbol being each hash-key of table
157 when
(uninternable-p symbol
) do
(remhash symbol table
))))
158 (drop-keys sb-c
::*backend-parsed-vops
*)
159 (drop-keys sb-c
::*backend-template-names
*))
160 ;; A structure constructor name, in particular !MAKE-SAETP,
161 ;; can't be uninterned if referenced by a defstruct-description.
162 ;; So loop over all structure classoids and clobber any
163 ;; symbol that should be uninternable.
164 (maphash (lambda (classoid layout
)
165 (when (structure-classoid-p classoid
)
166 (let ((dd (layout-%info layout
)))
167 (setf (dd-constructors dd
)
168 (delete-if (lambda (x)
169 (and (consp x
) (uninternable-p (car x
))))
170 (dd-constructors dd
))))))
171 (classoid-subclasses (find-classoid t
)))
172 ;; PATHNAME is not a structure-classoid
173 (setf (sb-kernel:dd-constructors
(sb-kernel:find-defstruct-description
'pathname
))
175 ;; Todo: perform one pass, then a full GC, then a final pass to confirm
176 ;; it worked. It should be an error if any uninternable symbols remain,
177 ;; but at present there are about 7 symbols with referrers.
178 (with-package-iterator (iter (list-all-packages) :internal
:external
)
179 (loop (multiple-value-bind (winp symbol accessibility package
) (iter)
180 (declare (ignore accessibility
))
183 (when (uninternable-p symbol
)
184 ;; Uninternable symbols which are referenced by other stuff
185 ;; can't disappear from the image, but we don't need to preserve
186 ;; their functions, so FMAKUNBOUND them. This doesn't have
187 ;; the intended effect if the function shares a code-component
188 ;; with non-cold-init lambdas. Though the cold-init function is
189 ;; never called post-build, it is not discarded. Also, I suspect
190 ;; that the following loop should print nothing, but it does:
192 (sb-vm:map-allocated-objects
193 (lambda (obj type size
)
194 (declare (ignore size
))
195 (when (= type sb-vm
:code-header-widetag
)
196 (let ((name (sb-c::debug-info-name
197 (sb-kernel:%code-debug-info obj
))))
198 (when (and (stringp name
) (search "COLD-INIT-FORMS" name
))
203 (unintern symbol package
))))))
204 (sb-int:dohash
((k v
) sb-c
::*backend-parsed-vops
*)
206 (setf (sb-c::vop-parse-body v
) nil
))
209 ;;; Check for potentially bad format-control strings
210 (defun scan-format-control-strings ()
211 (labels ((possibly-ungood-package-reference (string)
212 ;; We want to see nothing SB-package-like at all
213 (or (search "sb-" string
:test
#'char-equal
)
214 ;; catch mistakes due to imitating the way things used to be
215 (search "sb!" string
:test
#'char-equal
)))
216 (possibly-format-control (string)
217 (when (find #\~ string
)
218 ;; very likely to be a format control if it parses OK.
219 ;; Possibly not, but false positives are acceptable.
221 (and (typep x
'sb-format
::format-directive
)
222 (eql (sb-format::directive-character x
) #\
/)
223 (possibly-ungood-package-reference
225 (sb-format::directive-start x
)
226 (sb-format::directive-end x
)))))
228 (sb-format::%tokenize-control-string
229 string
0 (length string
) nil
))))))
231 (sb-vm:map-allocated-objects
232 (lambda (obj type size
)
233 (declare(ignore type size
))
234 (when (and (stringp obj
) (possibly-format-control obj
))
235 (push (make-weak-pointer obj
) wps
)))
239 (sb-int:binding
* ((v (weak-pointer-value wp
) :exit-if-null
))
240 (format t
"Found string ~S~%" v
)))
241 (warn "Potential problem with format-control strings.
242 Please check that all strings which were not recognizable to the compiler
243 (as the first argument to WARN, etc.) are wrapped in SB-FORMAT:TOKENS"))
246 ;;; If the SB-DOC internal feature is not present, remove any and all
247 ;;; docstrings that snuck in (as can happen with any file compiled in
249 (unless (member :sb-doc sb-impl
:+internal-features
+)
251 (macrolet ((clear-it (place)
253 ,(if (typep place
'(cons (eql sb-int
:info
)))
254 `(sb-int:clear-info
,@(cdr place
))
257 ;; 1. Functions, macros, special operators
258 (sb-vm:map-allocated-objects
259 (lambda (obj type size
)
260 (declare (ignore size
))
262 (#.sb-vm
:code-header-widetag
263 (dotimes (i (sb-kernel:code-n-entries obj
))
264 (let ((f (sb-kernel:%code-entry-point obj i
)))
265 (clear-it (sb-kernel:%simple-fun-doc f
)))))
266 (#.sb-vm
:instance-widetag
267 (when (typep obj
'class
)
268 (when (slot-boundp obj
'sb-pcl
::%documentation
)
269 (clear-it (slot-value obj
'sb-pcl
::%documentation
)))))
270 (#.sb-vm
:funcallable-instance-widetag
271 (when (typep obj
'standard-generic-function
)
272 (when (slot-boundp obj
'sb-pcl
::%documentation
)
273 (clear-it (slot-value obj
'sb-pcl
::%documentation
)))))))
275 ;; 2. Variables, types, and anything else
277 (let ((expander (sb-int:info
:setf
:expander s
)))
278 (when (typep expander
'(cons t
(cons string
)))
279 (setf (second expander
) nil
)))
280 (dolist (category '(:variable
:type
:typed-structure
))
281 (clear-it (sb-int:info category
:documentation s
)))
282 (clear-it (sb-int:info
:random-documentation
:stuff s
))))
284 (format t
"~&Removed ~D doc string~:P" count
)))
288 ;; Remove source forms of compiled-to-memory lambda expressions.
289 ;; The disassembler is the major culprit for retention of these,
290 ;; but there are others and I don't feel like figuring out where from.
291 ;; Globally declaiming EVAL-STORE-SOURCE-FORM 0 would work too,
292 ;; but isn't it nice to know that the logic for storing the forms
293 ;; actually works? (Yes)
294 (sb-vm:map-allocated-objects
295 (lambda (obj type size
)
296 (declare (ignore size
))
298 (#.sb-vm
:instance-widetag
299 (when (typep obj
'sb-c
::core-debug-source
)
300 (setf (sb-c::core-debug-source-form obj
) nil
)))
301 (#.sb-vm
:code-header-widetag
302 (dotimes (i (sb-kernel:code-n-entries obj
))
303 (let ((fun (sb-kernel:%code-entry-point obj i
)))
304 (when (sb-kernel:%simple-fun-lexpr fun
)
305 (setf (sb-impl::%simple-fun-source fun
)
306 (sb-impl::%simple-fun-doc fun
))))))))
309 ;; Disable the format-control optimizer for ERROR and WARN
310 ;; while preserving the argument-checking logic. Technically the optimizer is
311 ;; probably ok to leave in, but the spec is ambiguous as to whether
312 ;; implicit compile-time transformations on format strings is permitted.
313 ;; http://www.lispworks.com/documentation/HyperSpec/Issues/iss170_w.htm
314 ;; seems to imply that it is, but I would imagine that users don't expect it.
315 (setq sb-c
::*optimize-format-strings
* nil
)
317 ;; Fix unknown types in globaldb
321 (multiple-value-bind (type present
)
322 (sb-int:info kind
:type s
)
324 (sb-kernel:ctype-p type
)
325 (sb-kernel:contains-unknown-type-p type
))
326 (setf (sb-int:info kind
:type s
)
327 (sb-kernel:specifier-type
(sb-kernel:type-specifier type
)))
331 (unless (sb-impl::!c-runtime-noinform-p
)
332 (let ((*print-pretty
* nil
)
333 (*print-length
* nil
))
334 (format t
"~&; Fixed types: ~S~%" (sort l
#'string
<)))))
336 ;; Unintern no-longer-needed stuff before the possible PURIFY in
337 ;; SAVE-LISP-AND-DIE.
338 #-sb-devel
(!unintern-init-only-stuff
)
341 (do-all-symbols (symbol)
342 ;; Don't futz with the header of static symbols.
343 ;; Technically LOGIOR-HEADER-BITS can only be used on an OTHER-POINTER-LOWTAG
344 ;; objects, so modifying NIL should not ever work, but it's especially wrong
345 ;; on ppc64 where OTHER- and LIST- pointer lowtags are 10 bytes apart instead
346 ;; of 8, so this was making a random alteration to the header.
347 (unless (eq (heap-allocated-p symbol
) :static
)
348 (sb-kernel:logior-header-bits symbol sb-vm
::+symbol-initial-core
+))
350 ;; A symbol whose INFO slot underwent any kind of manipulation
351 ;; such that it now has neither properties nor globaldb info,
352 ;; can have the slot set back to NIL if it wasn't already.
353 (when (and (sb-kernel:symbol-%info symbol
) ; "raw" value is something
354 ;; but both "cooked" values are empty
355 (null (sb-kernel:symbol-dbinfo symbol
))
356 (null (symbol-plist symbol
)))
357 (sb-sys:%primitive sb-c
:set-slot symbol nil
358 'make-symbol sb-vm
:symbol-info-slot sb-vm
:other-pointer-lowtag
)))
363 ;;; resetting compilation policy to neutral values in preparation for
364 ;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
365 ;;; SB-C::*POLICY* has file scope)
366 (setq sb-c
::*policy
* (copy-structure sb-c
::**baseline-policy
**))
368 ;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
369 (dolist (rt (list sb-impl
::*standard-readtable
* *debug-readtable
*))
370 (setf (readtable-base-char-preference rt
) :symbols
))
371 ;;; Change the internal constructor's default too.
372 (let ((dsd sb-kernel
::(find 'sb-impl
::%readtable-string-preference
373 (dd-slots (find-defstruct-description 'readtable
))
375 (funcall #'(setf slot-value
) 'character dsd
'sb-kernel
::default
))
377 ;;; The system is complete now, all standard functions are
380 ;;; In case there is xref data for internals, repack it here to
381 ;;; achieve a more compact encoding.
383 ;;; However, repacking changes
384 ;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
385 ;;; the interpretation of xref data written into and loaded from
386 ;;; fasls. Since fasls should be compatible between images originating
387 ;;; from the same SBCL build, REPACK-XREF is of no use after the
388 ;;; target image has been built.
389 (when (member :sb-xref-for-internals sb-impl
:+internal-features
+)
390 (sb-c::repack-xref
:verbose
1))
391 (fmakunbound 'sb-c
::repack-xref
)
393 (load (merge-pathnames "src/code/shaketree" *load-pathname
*))
394 (defun asm-inst-p (symbol)
395 ;; Assembler instruction names can't be made external because to do so would
396 ;; conflict with common-lisp symbols. Notable examples are PUSH and POP.
397 ;; So other criteria must pertain to detecting the important symbols.
398 ;; And as we don't need to preserve Lisp macros but do need to retain
399 ;; assembler macro instructions, those merit special consideration.
400 ;; Additionally, a DEFUN may co-exist with an identically named macro
401 ;; instruction. (I'm not happy about it, but that's historical baggage).
402 ;; A macro instruction is recognizable to INST by a naming convention
403 ;; that is unused for anything else by way of being inconvenient to use -
404 ;; a symbol whose print name start with "M:" is a macro instruction.
405 (or (get symbol
'sb-disassem
::instructions
)
406 (let ((name (string symbol
)))
407 (and (> (length name
) 2)
408 (string= name
"M:" :end1
2)))))
412 (sb-impl::package-external-symbol-count x
)
413 (sb-impl::package-internal-symbol-count x
)))
414 (sort (list-all-packages) #'string
< :key
'package-name
))))
416 ;; Remove inline expansions
417 (do-symbols (symbol #.
(find-package "SB-C"))
418 (when (equal (symbol-package symbol
) #.
(find-package "SB-C"))
419 (sb-int:clear-info
:function
:inlining-data symbol
)
420 (sb-int:clear-info
:function
:inlinep symbol
)))
421 (sb-impl::shake-packages
422 ;; Development mode: retain all symbols with any system-related properties
424 (lambda (symbol accessibility
)
425 (declare (ignore accessibility
))
426 (or (sb-kernel:symbol-%info symbol
)
427 (sb-kernel:%symbol-function symbol
)
428 (and (boundp symbol
) (not (keywordp symbol
)))))
429 ;; Release mode: retain all symbols satisfying this intricate test
431 (lambda (symbol accessibility
)
432 (case (symbol-package symbol
)
433 (#.
(find-package "SB-VM")
434 (or (eq accessibility
:external
)
435 ;; overapproximate what we need for contribs and tests
436 (member symbol
'(sb-vm::map-referencing-objects
437 sb-vm
::map-stack-references
438 sb-vm
::reconstitute-object
439 sb-vm
::points-to-arena
440 ;; need this for defining a vop which
441 ;; tests the x86-64 allocation profiler
443 ;; Naughty outside-world code uses these.
444 #+x86-64 sb-vm
::reg-in-size
))
445 (let ((s (string symbol
))) (and (search "THREAD-" s
) (search "-SLOT" s
)))
446 (search "-OFFSET" (string symbol
))
447 (search "-TN" (string symbol
))))
448 (#.
(find-package "SB-ALIEN")
449 (or (eq accessibility
:external
) (eq symbol
'sb-alien
::alien-callback-p
)))
450 (#.
(mapcar 'find-package
451 '("SB-ASSEM" "SB-BROTHERTREE" "SB-DISASSEM" "SB-FORMAT"
452 "SB-IMPL" "SB-KERNEL" "SB-MOP" "SB-PCL" "SB-PRETTY" "SB-PROFILE"
453 "SB-REGALLOC" "SB-SYS" "SB-UNICODE" "SB-UNIX" "SB-WALKER"))
454 ;; Assume all and only external symbols must be retained
455 (eq accessibility
:external
))
456 (#.
(find-package "SB-C")
457 (or (eq accessibility
:external
)
458 (member symbol
'(sb-c::tab sb-c
::scramble
))))
459 (#.
(find-package "SB-LOOP")
460 (or (eq accessibility
:external
)
461 ;; Retain some internals to keep CLSQL working.
462 (member symbol
'(sb-loop::*loop-epilogue
*
463 sb-loop
::add-loop-path
))))
464 (#.
(find-package "SB-LOCKLESS")
465 (or (eq accessibility
:external
)
466 (member symbol
'(sb-lockless::+hash-nbits
+)))) ; for a test
467 (#.
(find-package "SB-THREAD")
468 (or (eq accessibility
:external
)
469 ;; for some reason a recent change caused the tree-shaker to drop MAKE-SPINLOCK
470 ;; which makes sense. I'm not sure what was rooting the symbol.
471 ;; However the :spinlock-api test in threads.impure asserts that spinlock symbols
472 ;; exist despite being internal symbols.
473 (sb-int:info
:function
:deprecated symbol
)))
474 (#.
(find-package "SB-FASL")
475 ;; Retain +BACKEND-FASL-FILE-IMPLEMENTATION+ and +FASL-FILE-VERSION+
476 ;; (and anything else otherwise reachable)
477 (and (eq accessibility
:external
)
479 (#.
(find-package "SB-BIGNUM")
480 ;; There are 2 important external symbols for sb-gmp.
481 ;; Other externals can disappear.
482 (member symbol
'(sb-bignum:%allocate-bignum
483 sb-bignum
:make-small-bignum
)))
485 (if (eq (symbol-package symbol
)
486 sb-assem
::*backend-instruction-set-package
*)
487 (or (eq accessibility
:external
) (asm-inst-p symbol
))
488 ;; By default, retain any symbol with any attachments
489 (or (sb-kernel:symbol-%info symbol
)
490 (sb-kernel:%symbol-function symbol
)
491 (and (boundp symbol
) (not (keywordp symbol
))))))))
492 :verbose nil
:print nil
)
493 (unintern 'sb-impl
::shake-packages
'sb-impl
)
494 (let ((sum-delta-ext 0)
496 (format t
"~&~26TExternal | Internal~%")
497 (dolist (entry counts
)
498 (let* ((ext (sb-impl::package-external-symbol-count
(car entry
)))
499 (int (sb-impl::package-internal-symbol-count
(car entry
)))
500 (delta-ext (- ext
(cadr entry
)))
501 (delta-int (- int
(caddr entry
))))
502 (incf sum-delta-ext delta-ext
)
503 (incf sum-delta-int delta-int
)
504 (assert (<= delta-ext
0))
505 (assert (<= delta-int
0))
506 (format t
"~20a | ~5d (~5@d) | ~5d (~5@d)~%"
507 (package-name (car entry
))
508 ext delta-ext int delta-int
)))
509 (format t
"~28t (~5@d) | (~5@d) = (~d)~%"
510 sum-delta-ext sum-delta-int
511 (+ sum-delta-ext sum-delta-int
))))
513 (scan-format-control-strings)
516 (rename-package "COMMON-LISP" "COMMON-LISP" '("SB-XC" "CL"))
518 ;;; Lock internal packages
520 (not sb-devel-lock-packages
))
521 (dolist (p (list-all-packages))
522 (unless (member p
(mapcar #'find-package
'("KEYWORD" "CL-USER")))
523 (sb-ext:lock-package p
)))
525 ;;; Clean up stray symbols from the CL-USER package.
526 (with-package-iterator (iter "CL-USER" :internal
:external
)
527 (loop (multiple-value-bind (winp symbol
) (iter)
528 (if winp
(unintern symbol
"CL-USER") (return)))))
530 (setq sb-c
:*compile-to-memory-space
* :auto
)
531 (when (find-package "SB-INTERPRETER") (setq sb-ext
:*evaluator-mode
* :interpret
))
532 #+x86-64
(sb-ext:fold-identical-code
:aggressive t
:preserve-docstrings t
)
534 ;; See comments in 'readtable.lisp'
535 (setf (readtable-base-char-preference *readtable
*) :symbols
)
538 "done with warm.lisp, about to SAVE-LISP-AND-DIE"
541 This is the actual
"name" of a toplevel code component that gets dumped to fasl
542 when compiling src
/pcl
/boot. Not only does it contain a format control string in
543 its raw representation
, this is a complete and utter waste of time to dump.
544 We really ought to try a LOT harder not to produce such garbage metadata
:
547 (write (sb-c::compiled-debug-fun-toplevel-name
548 (elt (sb-c::compiled-debug-info-fun-map
*cdi
*) 0))
549 :level nil
:length nil
))
551 (SB-C::TOP-LEVEL-FORM
552 (LABELS ((WARN-PARSE (SPECIALIZER &OPTIONAL CONDITION
)
553 (STYLE-WARN "~@<Cannot parse specializer ~S in ~S~@[: ~A~].~@:>"
554 SPECIALIZER
# CONDITION
))
555 (WARN-FIND (CONDITION NAME PROTO-GENERIC-FUNCTION PROTO-METHOD
)
556 (WARN CONDITION
:FORMAT-CONTROL
557 #<(SIMPLE-BASE-STRING
558 228) ~
@<Cannot find type for specializer ~
559 ~
/sb-ext
:print-symbol-with-prefix
/ when executing ~S ~
560 for a ~
/sb-impl
:print-type-specifier
/ of a ~
561 ~
/sb-imp...
{1003A2BC8F
}>
562 :FORMAT-ARGUMENTS
#))
563 (CLASS-NAME-TYPE-SPECIFIER
564 (NAME PROTO-GENERIC-FUNCTION PROTO-METHOD
&OPTIONAL
#)
567 (DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER
/SYMBOL
568 (PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER
)
570 (WHEN SPECIALIZER
#)))
571 (DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER
/T
572 (PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER
)
574 (WHEN SPECIALIZER
#)))
575 (DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER
/CLASS-EQ-SPECIALIZER
576 (PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER
)
577 (SPECIALIZER-TYPE-SPECIFIER PROTO-GENERIC-FUNCTION PROTO-METHOD
578 (SPECIALIZER-CLASS SPECIALIZER
)))
579 (DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER
/EQL-SPECIALIZER
580 (PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER
)
581 (DECLARE (IGNORE PROTO-GENERIC-FUNCTION PROTO-METHOD
))
582 `(EQL SB-IMPL
::COMMA
))
583 (DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER
/STRUCTURE-CLASS
584 (PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER
)
585 (DECLARE (IGNORE PROTO-GENERIC-FUNCTION PROTO-METHOD
))
586 (CLASS-NAME SPECIALIZER
))
587 (DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER
/SYSTEM-CLASS
588 (PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER
)
589 (DECLARE (IGNORE PROTO-GENERIC-FUNCTION PROTO-METHOD
))
590 (CLASS-NAME SPECIALIZER
))
591 (DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER
/CLASS
592 (PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER
)