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