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
))
210 ;; Used for inheriting from other VOPs, not needed in the target.
211 (setf sb-c
::*backend-parsed-vops
* (make-hash-table))
215 ;;; Check for potentially bad format-control strings
216 (defun scan-format-control-strings ()
217 (labels ((possibly-ungood-package-reference (string)
218 ;; We want to see nothing SB-package-like at all
219 (or (search "sb-" string
:test
#'char-equal
)
220 ;; catch mistakes due to imitating the way things used to be
221 (search "sb!" string
:test
#'char-equal
)))
222 (possibly-format-control (string)
223 (when (find #\~ string
)
224 ;; very likely to be a format control if it parses OK.
225 ;; Possibly not, but false positives are acceptable.
227 (and (typep x
'sb-format
::format-directive
)
228 (eql (sb-format::directive-character x
) #\
/)
229 (possibly-ungood-package-reference
231 (sb-format::directive-start x
)
232 (sb-format::directive-end x
)))))
234 (sb-format::%tokenize-control-string
235 string
0 (length string
) nil
))))))
237 (sb-vm:map-allocated-objects
238 (lambda (obj type size
)
239 (declare(ignore type size
))
240 (when (and (stringp obj
) (possibly-format-control obj
))
241 (push (make-weak-pointer obj
) wps
)))
245 (sb-int:binding
* ((v (weak-pointer-value wp
) :exit-if-null
))
246 (format t
"Found string ~S~%" v
)))
247 (warn "Potential problem with format-control strings.
248 Please check that all strings which were not recognizable to the compiler
249 (as the first argument to WARN, etc.) are wrapped in SB-FORMAT:TOKENS"))
252 ;;; If the SB-DOC internal feature is not present, remove any and all
253 ;;; docstrings that snuck in (as can happen with any file compiled in
255 (unless (member :sb-doc sb-impl
:+internal-features
+)
257 (macrolet ((clear-it (place)
259 ,(if (typep place
'(cons (eql sb-int
:info
)))
260 `(sb-int:clear-info
,@(cdr place
))
263 ;; 1. Functions, macros, special operators
264 (sb-vm:map-allocated-objects
265 (lambda (obj type size
)
266 (declare (ignore size
))
268 (#.sb-vm
:code-header-widetag
269 (dotimes (i (sb-kernel:code-n-entries obj
))
270 (let ((f (sb-kernel:%code-entry-point obj i
)))
271 (clear-it (sb-kernel:%simple-fun-doc f
)))))
272 (#.sb-vm
:instance-widetag
273 (when (typep obj
'class
)
274 (when (slot-boundp obj
'sb-pcl
::%documentation
)
275 (clear-it (slot-value obj
'sb-pcl
::%documentation
)))))
276 (#.sb-vm
:funcallable-instance-widetag
277 (when (typep obj
'standard-generic-function
)
278 (when (slot-boundp obj
'sb-pcl
::%documentation
)
279 (clear-it (slot-value obj
'sb-pcl
::%documentation
)))))))
281 ;; 2. Variables, types, and anything else
283 (let ((expander (sb-int:info
:setf
:expander s
)))
284 (when (typep expander
'(cons t
(cons string
)))
285 (setf (second expander
) nil
)))
286 (dolist (category '(:variable
:type
:typed-structure
))
287 (clear-it (sb-int:info category
:documentation s
)))
288 (clear-it (sb-int:info
:random-documentation
:stuff s
))))
290 (format t
"~&Removed ~D doc string~:P" count
)))
293 #+sb-core-compression
294 (defun compress-debug-info (code)
295 (let ((info (sb-c::%code-debug-info code
)))
296 (when (typep info
'sb-c
::compiled-debug-info
)
297 (let ((map (sb-c::compiled-debug-info-fun-map info
)))
298 (when (typep map
'(simple-array (unsigned-byte 8) (*)))
299 (sb-alien:with-alien
((compress-vector (function int
(* char
) size-t
) :extern
"compress_vector"))
300 (sb-sys:with-pinned-objects
(map)
301 (sb-alien:alien-funcall compress-vector
302 (sb-sys:int-sap
(sb-kernel:get-lisp-obj-address map
))
305 ;; Remove source forms of compiled-to-memory lambda expressions.
306 ;; The disassembler is the major culprit for retention of these,
307 ;; but there are others and I don't feel like figuring out where from.
308 ;; Globally declaiming EVAL-STORE-SOURCE-FORM 0 would work too,
309 ;; but isn't it nice to know that the logic for storing the forms
310 ;; actually works? (Yes)
311 (sb-vm:map-allocated-objects
312 (lambda (obj type size
)
313 (declare (ignore size
))
315 (#.sb-vm
:instance-widetag
316 (when (typep obj
'sb-c
::core-debug-source
)
317 (setf (sb-c::core-debug-source-form obj
) nil
)))
318 (#.sb-vm
:code-header-widetag
319 #+sb-core-compression
320 (compress-debug-info obj
)
321 (dotimes (i (sb-kernel:code-n-entries obj
))
322 (let ((fun (sb-kernel:%code-entry-point obj i
)))
323 (when (sb-kernel:%simple-fun-lexpr fun
)
324 (setf (sb-impl::%simple-fun-source fun
)
325 (sb-impl::%simple-fun-doc fun
))))))))
328 ;; Disable the format-control optimizer for ERROR and WARN
329 ;; while preserving the argument-checking logic. Technically the optimizer is
330 ;; probably ok to leave in, but the spec is ambiguous as to whether
331 ;; implicit compile-time transformations on format strings is permitted.
332 ;; http://www.lispworks.com/documentation/HyperSpec/Issues/iss170_w.htm
333 ;; seems to imply that it is, but I would imagine that users don't expect it.
334 (setq sb-c
::*optimize-format-strings
* nil
)
336 ;; Fix unknown types in globaldb
340 (multiple-value-bind (type present
)
341 (sb-int:info kind
:type s
)
343 (sb-kernel:ctype-p type
)
344 (sb-kernel:contains-unknown-type-p type
))
345 (setf (sb-int:info kind
:type s
)
346 (sb-kernel:specifier-type
(sb-kernel:type-specifier type
)))
350 (unless (sb-impl::!c-runtime-noinform-p
)
351 (let ((*print-pretty
* nil
)
352 (*print-length
* nil
))
353 (format t
"~&; Fixed types: ~S~%" (sort l
#'string
<)))))
355 ;; Unintern no-longer-needed stuff before the possible PURIFY in
356 ;; SAVE-LISP-AND-DIE.
357 #-sb-devel
(!unintern-init-only-stuff
)
360 (do-all-symbols (symbol)
361 ;; Don't futz with the header of static symbols.
362 ;; Technically LOGIOR-HEADER-BITS can only be used on an OTHER-POINTER-LOWTAG
363 ;; objects, so modifying NIL should not ever work, but it's especially wrong
364 ;; on ppc64 where OTHER- and LIST- pointer lowtags are 10 bytes apart instead
365 ;; of 8, so this was making a random alteration to the header.
366 (unless (eq (heap-allocated-p symbol
) :static
)
367 (sb-kernel:logior-header-bits symbol sb-vm
::+symbol-initial-core
+))
369 ;; A symbol whose INFO slot underwent any kind of manipulation
370 ;; such that it now has neither properties nor globaldb info,
371 ;; can have the slot set back to NIL if it wasn't already.
372 (when (and (sb-kernel:symbol-%info symbol
) ; "raw" value is something
373 ;; but both "cooked" values are empty
374 (null (sb-kernel:symbol-dbinfo symbol
))
375 (null (symbol-plist symbol
)))
376 (sb-sys:%primitive sb-c
:set-slot symbol nil
377 'make-symbol sb-vm
:symbol-info-slot sb-vm
:other-pointer-lowtag
)))
382 ;;; resetting compilation policy to neutral values in preparation for
383 ;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
384 ;;; SB-C::*POLICY* has file scope)
385 (setq sb-c
::*policy
* (copy-structure sb-c
::**baseline-policy
**))
387 ;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
388 (dolist (rt (list sb-impl
::*standard-readtable
* *debug-readtable
*))
389 (setf (readtable-base-char-preference rt
) :symbols
))
390 ;;; Change the internal constructor's default too.
391 (let ((dsd sb-kernel
::(find 'sb-impl
::%readtable-string-preference
392 (dd-slots (find-defstruct-description 'readtable
))
394 (funcall #'(setf slot-value
) 'character dsd
'sb-kernel
::default
))
396 ;;; The system is complete now, all standard functions are
399 ;;; In case there is xref data for internals, repack it here to
400 ;;; achieve a more compact encoding.
402 ;;; However, repacking changes
403 ;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
404 ;;; the interpretation of xref data written into and loaded from
405 ;;; fasls. Since fasls should be compatible between images originating
406 ;;; from the same SBCL build, REPACK-XREF is of no use after the
407 ;;; target image has been built.
408 (when (member :sb-xref-for-internals sb-impl
:+internal-features
+)
409 (sb-c::repack-xref
:verbose
1))
410 (fmakunbound 'sb-c
::repack-xref
)
412 (load (merge-pathnames "src/code/shaketree" *load-pathname
*))
413 (defun asm-inst-p (symbol)
414 ;; Assembler instruction names can't be made external because to do so would
415 ;; conflict with common-lisp symbols. Notable examples are PUSH and POP.
416 ;; So other criteria must pertain to detecting the important symbols.
417 ;; And as we don't need to preserve Lisp macros but do need to retain
418 ;; assembler macro instructions, those merit special consideration.
419 ;; Additionally, a DEFUN may co-exist with an identically named macro
420 ;; instruction. (I'm not happy about it, but that's historical baggage).
421 ;; A macro instruction is recognizable to INST by a naming convention
422 ;; that is unused for anything else by way of being inconvenient to use -
423 ;; a symbol whose print name start with "M:" is a macro instruction.
424 (or (get symbol
'sb-disassem
::instructions
)
425 (let ((name (string symbol
)))
426 (and (> (length name
) 2)
427 (string= name
"M:" :end1
2)))))
431 (sb-impl::package-external-symbol-count x
)
432 (sb-impl::package-internal-symbol-count x
)))
433 (sort (list-all-packages) #'string
< :key
'package-name
))))
435 ;; Remove inline expansions
436 (do-symbols (symbol #.
(find-package "SB-C"))
437 (when (equal (symbol-package symbol
) #.
(find-package "SB-C"))
438 (sb-int:clear-info
:function
:inlining-data symbol
)
439 (sb-int:clear-info
:function
:inlinep symbol
)))
440 (sb-impl::shake-packages
441 ;; Development mode: retain all symbols with any system-related properties
443 (lambda (symbol accessibility
)
444 (declare (ignore accessibility
))
445 (or (sb-kernel:symbol-%info symbol
)
446 (sb-kernel:%symbol-function symbol
)
447 (and (boundp symbol
) (not (keywordp symbol
)))))
448 ;; Release mode: retain all symbols satisfying this intricate test
450 (lambda (symbol accessibility
)
451 (case (symbol-package symbol
)
452 (#.
(find-package "SB-VM")
453 (or (eq accessibility
:external
)
454 ;; overapproximate what we need for contribs and tests
455 (member symbol
`(sb-vm::map-referencing-objects
456 sb-vm
::map-stack-references
457 sb-vm
::reconstitute-object
458 sb-vm
::points-to-arena
459 ;; need this for defining a vop which
460 ;; tests the x86-64 allocation profiler
462 ,@(or #+(or x86 x86-64
) '(sb-vm::%vector-cas-pair
463 sb-vm
::%instance-cas-pair
464 sb-vm
::%cons-cas-pair
))
465 ;; Naughty outside-world code uses these.
466 #+x86-64 sb-vm
::reg-in-size
))
467 (let ((s (string symbol
))) (and (search "THREAD-" s
) (search "-SLOT" s
)))
468 (search "-OFFSET" (string symbol
))
469 (search "-TN" (string symbol
))))
470 (#.
(find-package "SB-ALIEN")
471 (or (eq accessibility
:external
) (eq symbol
'sb-alien
::alien-callback-p
)))
472 (#.
(mapcar 'find-package
473 '("SB-ASSEM" "SB-BROTHERTREE" "SB-DISASSEM" "SB-FORMAT"
474 "SB-IMPL" "SB-KERNEL" "SB-MOP" "SB-PCL" "SB-PRETTY" "SB-PROFILE"
475 "SB-REGALLOC" "SB-SYS" "SB-UNICODE" "SB-UNIX" "SB-WALKER"))
476 ;; Assume all and only external symbols must be retained
477 (eq accessibility
:external
))
478 (#.
(find-package "SB-C")
479 (or (eq accessibility
:external
)
480 (member symbol
'(sb-c::tab sb-c
::scramble
))))
481 (#.
(find-package "SB-LOOP")
482 (or (eq accessibility
:external
)
483 ;; Retain some internals to keep CLSQL working.
484 (member symbol
'(sb-loop::*loop-epilogue
*
485 sb-loop
::add-loop-path
))))
486 (#.
(find-package "SB-LOCKLESS")
487 (or (eq accessibility
:external
)
488 (member symbol
'(sb-lockless::+hash-nbits
+)))) ; for a test
489 (#.
(find-package "SB-THREAD")
490 (or (eq accessibility
:external
)
491 ;; for some reason a recent change caused the tree-shaker to drop MAKE-SPINLOCK
492 ;; which makes sense. I'm not sure what was rooting the symbol.
493 ;; However the :spinlock-api test in threads.impure asserts that spinlock symbols
494 ;; exist despite being internal symbols.
495 (sb-int:info
:function
:deprecated symbol
)))
496 (#.
(find-package "SB-FASL")
497 ;; Retain +BACKEND-FASL-FILE-IMPLEMENTATION+ and +FASL-FILE-VERSION+
498 ;; (and anything else otherwise reachable)
499 (and (eq accessibility
:external
)
501 (#.
(find-package "SB-BIGNUM")
502 ;; There are 2 important external symbols for sb-gmp, and 2
503 ;; important external symbols for sb-rotate-byte.
504 ;; Other externals can disappear.
505 (member symbol
'(sb-bignum:%allocate-bignum
506 sb-bignum
:maximum-bignum-length
508 sb-bignum
:make-small-bignum
)))
510 (if (eq (symbol-package symbol
)
511 sb-assem
::*backend-instruction-set-package
*)
512 (or (eq accessibility
:external
) (asm-inst-p symbol
))
513 ;; By default, retain any symbol with any attachments
514 (or (sb-kernel:symbol-%info symbol
)
515 (sb-kernel:%symbol-function symbol
)
516 (and (boundp symbol
) (not (keywordp symbol
))))))))
517 :verbose nil
:print nil
)
518 (unintern 'sb-impl
::shake-packages
'sb-impl
)
519 (let ((sum-delta-ext 0)
521 (format t
"~&~26TExternal | Internal~%")
522 (dolist (entry counts
)
523 (let* ((ext (sb-impl::package-external-symbol-count
(car entry
)))
524 (int (sb-impl::package-internal-symbol-count
(car entry
)))
525 (delta-ext (- ext
(cadr entry
)))
526 (delta-int (- int
(caddr entry
))))
527 (incf sum-delta-ext delta-ext
)
528 (incf sum-delta-int delta-int
)
529 (assert (<= delta-ext
0))
530 (assert (<= delta-int
0))
531 (format t
"~20a | ~5d (~5@d) | ~5d (~5@d)~%"
532 (package-name (car entry
))
533 ext delta-ext int delta-int
)))
534 (format t
"~28t (~5@d) | (~5@d) = (~d)~%"
535 sum-delta-ext sum-delta-int
536 (+ sum-delta-ext sum-delta-int
))))
538 (scan-format-control-strings)
540 (macrolet ((def-backward-compatible-sb-c-specials (pairs) ; for UIOP + ASDF
542 ,@(mapcar (lambda (pair)
543 `(define-symbol-macro ,(car pair
)
544 (,(sb-int:package-symbolicate
"SB-C" "CU-" (cdr pair
) "-COUNT")
545 sb-c
::*compilation-unit
*)))
547 ;; coece to a strict boolean
548 (define-symbol-macro sb-c
::*in-compilation-unit
* (not (null sb-c
::*compilation-unit
*)))
549 ;; the "specials" are all SETFable when and only when *IN-COMPILATION-UNIT* is T
550 (def-backward-compatible-sb-c-specials
551 sb-c
::((*aborted-compilation-unit-count
* .
"ABORTED")
552 (*compiler-error-count
* .
"ERROR")
553 (*compiler-warning-count
* .
"WARNING")
554 (*compiler-style-warning-count
* .
"STYLE-WARNING")
555 (*compiler-note-count
* .
"NOTE"))))
558 (rename-package "COMMON-LISP" "COMMON-LISP" '("SB-XC" "CL"))
560 ;;; Lock internal packages
562 (not sb-devel-lock-packages
))
563 (dolist (p (list-all-packages))
564 (unless (member p
(mapcar #'find-package
'("KEYWORD" "CL-USER")))
565 (sb-ext:lock-package p
)))
567 ;;; Clean up stray symbols from the CL-USER package.
568 (with-package-iterator (iter "CL-USER" :internal
:external
)
569 (loop (multiple-value-bind (winp symbol
) (iter)
570 (if winp
(unintern symbol
"CL-USER") (return)))))
572 (setq sb-c
:*compile-to-memory-space
* :auto
)
573 (when (find-package "SB-INTERPRETER") (setq sb-ext
:*evaluator-mode
* :interpret
))
574 #+x86-64
(sb-ext:fold-identical-code
:aggressive t
:preserve-docstrings t
)
576 ;; See comments in 'readtable.lisp'
577 (setf (readtable-base-char-preference *readtable
*) :symbols
)