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
)))
290 #+sb-core-compression
291 (defun compress-debug-info (code)
292 (let ((info (sb-c::%code-debug-info code
)))
293 (when (typep info
'sb-c
::compiled-debug-info
)
294 (let ((map (sb-c::compiled-debug-info-fun-map info
)))
295 (when (typep map
'(simple-array (unsigned-byte 8) (*)))
296 (sb-alien:with-alien
((compress-vector (function int
(* char
) size-t
) :extern
"compress_vector"))
297 (sb-sys:with-pinned-objects
(map)
298 (sb-alien:alien-funcall compress-vector
299 (sb-sys:int-sap
(sb-kernel:get-lisp-obj-address map
))
302 ;; Remove source forms of compiled-to-memory lambda expressions.
303 ;; The disassembler is the major culprit for retention of these,
304 ;; but there are others and I don't feel like figuring out where from.
305 ;; Globally declaiming EVAL-STORE-SOURCE-FORM 0 would work too,
306 ;; but isn't it nice to know that the logic for storing the forms
307 ;; actually works? (Yes)
308 (sb-vm:map-allocated-objects
309 (lambda (obj type size
)
310 (declare (ignore size
))
312 (#.sb-vm
:instance-widetag
313 (when (typep obj
'sb-c
::core-debug-source
)
314 (setf (sb-c::core-debug-source-form obj
) nil
)))
315 (#.sb-vm
:code-header-widetag
316 #+sb-core-compression
317 (compress-debug-info obj
)
318 (dotimes (i (sb-kernel:code-n-entries obj
))
319 (let ((fun (sb-kernel:%code-entry-point obj i
)))
320 (when (sb-kernel:%simple-fun-lexpr fun
)
321 (setf (sb-impl::%simple-fun-source fun
)
322 (sb-impl::%simple-fun-doc fun
))))))))
325 ;; Disable the format-control optimizer for ERROR and WARN
326 ;; while preserving the argument-checking logic. Technically the optimizer is
327 ;; probably ok to leave in, but the spec is ambiguous as to whether
328 ;; implicit compile-time transformations on format strings is permitted.
329 ;; http://www.lispworks.com/documentation/HyperSpec/Issues/iss170_w.htm
330 ;; seems to imply that it is, but I would imagine that users don't expect it.
331 (setq sb-c
::*optimize-format-strings
* nil
)
333 ;; Fix unknown types in globaldb
337 (multiple-value-bind (type present
)
338 (sb-int:info kind
:type s
)
340 (sb-kernel:ctype-p type
)
341 (sb-kernel:contains-unknown-type-p type
))
342 (setf (sb-int:info kind
:type s
)
343 (sb-kernel:specifier-type
(sb-kernel:type-specifier type
)))
347 (unless (sb-impl::!c-runtime-noinform-p
)
348 (let ((*print-pretty
* nil
)
349 (*print-length
* nil
))
350 (format t
"~&; Fixed types: ~S~%" (sort l
#'string
<)))))
352 ;; Unintern no-longer-needed stuff before the possible PURIFY in
353 ;; SAVE-LISP-AND-DIE.
354 #-sb-devel
(!unintern-init-only-stuff
)
357 (do-all-symbols (symbol)
358 ;; Don't futz with the header of static symbols.
359 ;; Technically LOGIOR-HEADER-BITS can only be used on an OTHER-POINTER-LOWTAG
360 ;; objects, so modifying NIL should not ever work, but it's especially wrong
361 ;; on ppc64 where OTHER- and LIST- pointer lowtags are 10 bytes apart instead
362 ;; of 8, so this was making a random alteration to the header.
363 (unless (eq (heap-allocated-p symbol
) :static
)
364 (sb-kernel:logior-header-bits symbol sb-vm
::+symbol-initial-core
+))
366 ;; A symbol whose INFO slot underwent any kind of manipulation
367 ;; such that it now has neither properties nor globaldb info,
368 ;; can have the slot set back to NIL if it wasn't already.
369 (when (and (sb-kernel:symbol-%info symbol
) ; "raw" value is something
370 ;; but both "cooked" values are empty
371 (null (sb-kernel:symbol-dbinfo symbol
))
372 (null (symbol-plist symbol
)))
373 (sb-sys:%primitive sb-c
:set-slot symbol nil
374 'make-symbol sb-vm
:symbol-info-slot sb-vm
:other-pointer-lowtag
)))
379 ;;; resetting compilation policy to neutral values in preparation for
380 ;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
381 ;;; SB-C::*POLICY* has file scope)
382 (setq sb-c
::*policy
* (copy-structure sb-c
::**baseline-policy
**))
384 ;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
385 (dolist (rt (list sb-impl
::*standard-readtable
* *debug-readtable
*))
386 (setf (readtable-base-char-preference rt
) :symbols
))
387 ;;; Change the internal constructor's default too.
388 (let ((dsd sb-kernel
::(find 'sb-impl
::%readtable-string-preference
389 (dd-slots (find-defstruct-description 'readtable
))
391 (funcall #'(setf slot-value
) 'character dsd
'sb-kernel
::default
))
393 ;;; The system is complete now, all standard functions are
396 ;;; In case there is xref data for internals, repack it here to
397 ;;; achieve a more compact encoding.
399 ;;; However, repacking changes
400 ;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
401 ;;; the interpretation of xref data written into and loaded from
402 ;;; fasls. Since fasls should be compatible between images originating
403 ;;; from the same SBCL build, REPACK-XREF is of no use after the
404 ;;; target image has been built.
405 (when (member :sb-xref-for-internals sb-impl
:+internal-features
+)
406 (sb-c::repack-xref
:verbose
1))
407 (fmakunbound 'sb-c
::repack-xref
)
409 (load (merge-pathnames "src/code/shaketree" *load-pathname
*))
410 (defun asm-inst-p (symbol)
411 ;; Assembler instruction names can't be made external because to do so would
412 ;; conflict with common-lisp symbols. Notable examples are PUSH and POP.
413 ;; So other criteria must pertain to detecting the important symbols.
414 ;; And as we don't need to preserve Lisp macros but do need to retain
415 ;; assembler macro instructions, those merit special consideration.
416 ;; Additionally, a DEFUN may co-exist with an identically named macro
417 ;; instruction. (I'm not happy about it, but that's historical baggage).
418 ;; A macro instruction is recognizable to INST by a naming convention
419 ;; that is unused for anything else by way of being inconvenient to use -
420 ;; a symbol whose print name start with "M:" is a macro instruction.
421 (or (get symbol
'sb-disassem
::instructions
)
422 (let ((name (string symbol
)))
423 (and (> (length name
) 2)
424 (string= name
"M:" :end1
2)))))
428 (sb-impl::package-external-symbol-count x
)
429 (sb-impl::package-internal-symbol-count x
)))
430 (sort (list-all-packages) #'string
< :key
'package-name
))))
432 ;; Remove inline expansions
433 (do-symbols (symbol #.
(find-package "SB-C"))
434 (when (equal (symbol-package symbol
) #.
(find-package "SB-C"))
435 (sb-int:clear-info
:function
:inlining-data symbol
)
436 (sb-int:clear-info
:function
:inlinep symbol
)))
437 (sb-impl::shake-packages
438 ;; Development mode: retain all symbols with any system-related properties
440 (lambda (symbol accessibility
)
441 (declare (ignore accessibility
))
442 (or (sb-kernel:symbol-%info symbol
)
443 (sb-kernel:%symbol-function symbol
)
444 (and (boundp symbol
) (not (keywordp symbol
)))))
445 ;; Release mode: retain all symbols satisfying this intricate test
447 (lambda (symbol accessibility
)
448 (case (symbol-package symbol
)
449 (#.
(find-package "SB-VM")
450 (or (eq accessibility
:external
)
451 ;; overapproximate what we need for contribs and tests
452 (member symbol
'(sb-vm::map-referencing-objects
453 sb-vm
::map-stack-references
454 sb-vm
::reconstitute-object
455 sb-vm
::points-to-arena
456 ;; need this for defining a vop which
457 ;; tests the x86-64 allocation profiler
459 ;; Naughty outside-world code uses these.
460 #+x86-64 sb-vm
::reg-in-size
))
461 (let ((s (string symbol
))) (and (search "THREAD-" s
) (search "-SLOT" s
)))
462 (search "-OFFSET" (string symbol
))
463 (search "-TN" (string symbol
))))
464 (#.
(find-package "SB-ALIEN")
465 (or (eq accessibility
:external
) (eq symbol
'sb-alien
::alien-callback-p
)))
466 (#.
(mapcar 'find-package
467 '("SB-ASSEM" "SB-BROTHERTREE" "SB-DISASSEM" "SB-FORMAT"
468 "SB-IMPL" "SB-KERNEL" "SB-MOP" "SB-PCL" "SB-PRETTY" "SB-PROFILE"
469 "SB-REGALLOC" "SB-SYS" "SB-UNICODE" "SB-UNIX" "SB-WALKER"))
470 ;; Assume all and only external symbols must be retained
471 (eq accessibility
:external
))
472 (#.
(find-package "SB-C")
473 (or (eq accessibility
:external
)
474 (member symbol
'(sb-c::tab sb-c
::scramble
))))
475 (#.
(find-package "SB-LOOP")
476 (or (eq accessibility
:external
)
477 ;; Retain some internals to keep CLSQL working.
478 (member symbol
'(sb-loop::*loop-epilogue
*
479 sb-loop
::add-loop-path
))))
480 (#.
(find-package "SB-LOCKLESS")
481 (or (eq accessibility
:external
)
482 (member symbol
'(sb-lockless::+hash-nbits
+)))) ; for a test
483 (#.
(find-package "SB-THREAD")
484 (or (eq accessibility
:external
)
485 ;; for some reason a recent change caused the tree-shaker to drop MAKE-SPINLOCK
486 ;; which makes sense. I'm not sure what was rooting the symbol.
487 ;; However the :spinlock-api test in threads.impure asserts that spinlock symbols
488 ;; exist despite being internal symbols.
489 (sb-int:info
:function
:deprecated symbol
)))
490 (#.
(find-package "SB-FASL")
491 ;; Retain +BACKEND-FASL-FILE-IMPLEMENTATION+ and +FASL-FILE-VERSION+
492 ;; (and anything else otherwise reachable)
493 (and (eq accessibility
:external
)
495 (#.
(find-package "SB-BIGNUM")
496 ;; There are 2 important external symbols for sb-gmp.
497 ;; Other externals can disappear.
498 (member symbol
'(sb-bignum:%allocate-bignum
499 sb-bignum
:make-small-bignum
)))
501 (if (eq (symbol-package symbol
)
502 sb-assem
::*backend-instruction-set-package
*)
503 (or (eq accessibility
:external
) (asm-inst-p symbol
))
504 ;; By default, retain any symbol with any attachments
505 (or (sb-kernel:symbol-%info symbol
)
506 (sb-kernel:%symbol-function symbol
)
507 (and (boundp symbol
) (not (keywordp symbol
))))))))
508 :verbose nil
:print nil
)
509 (unintern 'sb-impl
::shake-packages
'sb-impl
)
510 (let ((sum-delta-ext 0)
512 (format t
"~&~26TExternal | Internal~%")
513 (dolist (entry counts
)
514 (let* ((ext (sb-impl::package-external-symbol-count
(car entry
)))
515 (int (sb-impl::package-internal-symbol-count
(car entry
)))
516 (delta-ext (- ext
(cadr entry
)))
517 (delta-int (- int
(caddr entry
))))
518 (incf sum-delta-ext delta-ext
)
519 (incf sum-delta-int delta-int
)
520 (assert (<= delta-ext
0))
521 (assert (<= delta-int
0))
522 (format t
"~20a | ~5d (~5@d) | ~5d (~5@d)~%"
523 (package-name (car entry
))
524 ext delta-ext int delta-int
)))
525 (format t
"~28t (~5@d) | (~5@d) = (~d)~%"
526 sum-delta-ext sum-delta-int
527 (+ sum-delta-ext sum-delta-int
))))
529 (scan-format-control-strings)
532 (rename-package "COMMON-LISP" "COMMON-LISP" '("SB-XC" "CL"))
534 ;;; Lock internal packages
536 (not sb-devel-lock-packages
))
537 (dolist (p (list-all-packages))
538 (unless (member p
(mapcar #'find-package
'("KEYWORD" "CL-USER")))
539 (sb-ext:lock-package p
)))
541 ;;; Clean up stray symbols from the CL-USER package.
542 (with-package-iterator (iter "CL-USER" :internal
:external
)
543 (loop (multiple-value-bind (winp symbol
) (iter)
544 (if winp
(unintern symbol
"CL-USER") (return)))))
546 (setq sb-c
:*compile-to-memory-space
* :auto
)
547 (when (find-package "SB-INTERPRETER") (setq sb-ext
:*evaluator-mode
* :interpret
))
548 #+x86-64
(sb-ext:fold-identical-code
:aggressive t
:preserve-docstrings t
)
550 ;; See comments in 'readtable.lisp'
551 (setf (readtable-base-char-preference *readtable
*) :symbols
)