path: root/make-target-2-load.lisp

;;; Do warm init without compiling files.

;;; Get back to a reasonable state where all of the compiler works,
;;; as does SB-VM:HEXDUMP and MAP-ALLOCATED-OBJECTS, etc.
;;; before trying to define any more functions.
(defvar *compile-files-p* nil)
(load (merge-pathnames "src/cold/warm.lisp" *load-pathname*))

;; sb-xref-for-internals is actively harmful to tree-shaking.
;; Remove some symbols to make the hide-packages test pass.
#+sb-xref-for-internals
(progn
  (fmakunbound 'sb-kernel::type-class-fun-slot)
  (fmakunbound 'sb-kernel::new-ctype))

(sb-impl::!recompile-globaldb-checkfuns)

;;; Users don't want to know if there are multiple TLABs per se, but they do want
;;; to know if NEW-ARENA returns an arena, so give them a sensible feature name.
#+system-tlabs (push :arena-allocator *features*)

;;; Remove symbols from CL:*FEATURES* that should not be exposed to users.
(export 'sb-impl::+internal-features+ 'sb-impl)
(let* (#-sb-devel
       (non-target-features
        ;;
        ;; FIXME: I suspect that this list should be changed to its inverse-
        ;; features that _SHOULD_ go into SB-IMPL:+INTERNAL-FEATURES+ and
        ;; comments about the reasoning behind each, rather than features to
        ;; discard and reasons they're not needed. The default assumption should be
        ;; to drop any build-time feature that lacks a rationale to preserve it.
        ;;
        ;; READ-FROM-STRING prevents making references to
        ;; all these keywords from the source form itself.
        (read-from-string "
         (;; :SB-AFTER-XC-CORE is essentially an option flag to make-host-2
          :SB-AFTER-XC-CORE
          ;; CONS-PROFILING sets the initial compiler policy which persists
          ;; into the default baseline policy. It has no relevance post-build
          ;; in as much as policy can be changed later arbitrarily.
          :CONS-PROFILING
          ;; Used by nothing after compiling 'target-thread.lisp' or 'thread.c'
          :SB-FUTEX :OS-THREAD-STACK
          ;; These affect the BREAK instruction emitter, but the C code is able
          ;; to handle anything, and post-build we don't care which it is.
          :UD2-BREAKPOINTS :INT4-BREAKPOINTS
          ;; Uses of OS-PROVIDES-DLOPEN and -DLADDR are confined to src/code/foreign.lisp
          :OS-PROVIDES-DLOPEN :OS-PROVIDES-DLADDR
          ;; more-or-less confined to serve-event, except for a test which now
          ;; detects whether COMPUTE-POLLFDS is defined and therefore testable.
          :OS-PROVIDES-POLL
          ;; Silly feature we add in because additive features are more sensible
          ;; than subtractive ones. So you opt out, not in, to having *LOAD-TRUENAME*
          ;; eagerly bound.
          :ANSI-COMPLIANT-LOAD-TRUENAME
          ;; The final batch of symbols is strictly for C. The LISP_FEATURE_
          ;; prefix on the corresponding #define is unfortunate.
          :GCC-TLS :USE-SYS-MMAP
          ;;; Enforce using of posix semaphores on Darwin instead of dispatch.
          :USE-DARWIN-POSIX-SEMAPHORES
          ;; only for 'src/runtime/wrap.h'
          :OS-PROVIDES-BLKSIZE-T
          ;; only for src/runtime/run-program.c
          :OS-PROVIDES-CLOSE-RANGE-WRAPPER)"))
       (public-features
        (cons
         sb-impl::!sbcl-architecture
         (read-from-string "
          (:COMMON-LISP :SBCL :ANSI-CL :IEEE-FLOATING-POINT
           :64-BIT ; choice of word size. 32-bit if absent
           :BIG-ENDIAN :LITTLE-ENDIAN ; endianness: pick one and only one
           :BSD :UNIX :LINUX :WIN32 :DARWIN :SUNOS :ANDROID ; OS: pick one or more
           :FREEBSD :GNU-KFREEBSD :OPENBSD :NETBSD :DRAGONFLY :HAIKU
           :MACH-O :ELF ; obj file format: pick zero or one
           ;; I would argue that this should not be exposed,
           ;; but I would also anticipate blowback from removing it.
           :GENCGC :MARK-REGION-GC ; GC: pick one and only one
           :ARENA-ALLOCATOR :ALLOCATION-SIZE-HISTOGRAM
           ;; Can't use s-l-a-d :compression safely without it
           :SB-CORE-COMPRESSION
           ;; Features that are also in *FEATURES-POTENTIALLY-AFFECTING-FASL-FORMAT*
           ;; and would probably mess up something if made non-public,
           ;; though I don't think they should all be public.
           :MSAN :UBSAN
           :SB-SAFEPOINT
           :SB-THREAD :SB-UNICODE
           ;; Things which (I think) at least one person has requested be kept around
           :SB-LDB
           ;; We keep the :SB-PACKAGE-LOCKS feature despite it no longer
           ;; affecting the build. (It's not a choice any more)
           :SB-PACKAGE-LOCKS
           ;; unsure, I think this is for end-user consumption,
           ;; though every release of SBCL since eons ago has had local nicknames.
           :PACKAGE-LOCAL-NICKNAMES
           ;; Developer mode features. A release build will never have them,
           ;; hence it makes no difference whether they're public or not.
           :SB-DEVEL :SB-DEVEL-LOCK-PACKAGES)")))
       #-sb-devel
       (removable-features
        (append non-target-features public-features)))
  (defconstant sb-impl:+internal-features+
    ;;; Well, who would have guessed that our internal features list would nicely
    ;;; repair damage induced by ASDF, namely: ASDF removes features when loaded.
    ;;; Take a look at (DEFUN DETECT-OS) in uiop.lisp if you don't believe it,
    ;;; and watch it in action after (require "ASDF") -
    ;;;
    ;;; * *FEATURES* =>
    ;;; (:X86-64 :64-BIT :ANSI-CL :COMMON-LISP :ELF :GENCGC :HAIKU :IEEE-FLOATING-POINT
    ;;; :LITTLE-ENDIAN :PACKAGE-LOCAL-NICKNAMES :SB-LDB
    ;;; :SB-PACKAGE-LOCKS :SB-UNICODE :SBCL :UNIX)
    ;;;
    ;;; * (require :asdf)
    ;;; ("ASDF" "asdf" "UIOP" "uiop")
    ;;; * *FEATURES*
    ;;; (:ASDF3.3 :ASDF3.2 :ASDF3.1 :ASDF3 :ASDF2 :ASDF :OS-UNIX
    ;;; :NON-BASE-CHARS-EXIST-P :ASDF-UNICODE :X86-64 :64-BIT :ANSI-CL :COMMON-LISP
    ;;; :ELF :GENCGC :IEEE-FLOATING-POINT :LITTLE-ENDIAN :PACKAGE-LOCAL-NICKNAMES
    ;;; :SB-LDB :SB-PACKAGE-LOCKS :SB-UNICODE :SBCL :UNIX)
    ;;;
    ;;; So, what the heck happened to :HAIKU? It's gone.
    ;;; Well this is pure evil. Just madness.
    ;;; However, by stashing an extra copy of :HAIKU in the internal feature list,
    ;;; we can stuff it back in because our contrib builder first loads ASDF
    ;;; and then rebinds *FEATURES* with the union of the internal ones.
    (append #+haiku '(:haiku)
            (remove-if (lambda (x) (member x #+sb-devel public-features
                                             #-sb-devel removable-features)) *features*)))
  (setq *features* (remove-if-not (lambda (x) (member x public-features))
                                  *features*)))

;;; There's a fair amount of machinery which is needed only at cold
;;; init time, and should be discarded before freezing the final
;;; system. We discard it by uninterning the associated symbols.
;;; Rather than using a special table of symbols to be uninterned,
;;; which might be tedious to maintain, instead we use a hack:
;;; anything whose name matches a magic character pattern is
;;; uninterned.
;;; Additionally, you can specify an arbitrary way to destroy
;;; random bootstrap stuff on per-package basis.
(defun !unintern-init-only-stuff (&aux result)
  (dolist (package (list-all-packages))
    (sb-int:awhen (find-symbol "!REMOVE-BOOTSTRAP-SYMBOLS" package)
      (funcall sb-int:it)))
  (dolist (list sb-int:*!removable-symbols*)
    (let ((package (find-package (car list))))
      (dolist (symbol (cdr list))
        (fmakunbound symbol)
        (unintern symbol package))))
  sb-kernel::
  (flet ((uninternable-p (symbol)
           (let ((name (symbol-name symbol)))
             (or (and (>= (length name) 1) (char= (char name 0) #\!))
                 (and (>= (length name) 2) (string= name "*!" :end1 2))
                 (memq symbol
                       '(sb-c::sb-pcl sb-c::sb-impl sb-c::sb-kernel
                         sb-c::sb-c sb-c::sb-int))))))
    ;; Delete bootstrap-only vops
    (flet ((drop-keys (table)
             (loop for symbol being each hash-key of table
                   when (uninternable-p symbol) do (remhash symbol table))))
      (drop-keys sb-c::*backend-parsed-vops*)
      (drop-keys sb-c::*backend-template-names*))
    ;; A structure constructor name, in particular !MAKE-SAETP,
    ;; can't be uninterned if referenced by a defstruct-description.
    ;; So loop over all structure classoids and clobber any
    ;; symbol that should be uninternable.
    (maphash (lambda (classoid layout)
               (when (structure-classoid-p classoid)
                 (let ((dd (layout-%info layout)))
                   (setf (dd-constructors dd)
                         (delete-if (lambda (x)
                                      (and (consp x) (uninternable-p (car x))))
                                    (dd-constructors dd))))))
             (classoid-subclasses (find-classoid t)))
    ;; PATHNAME is not a structure-classoid
    (setf (sb-kernel:dd-constructors (sb-kernel:find-defstruct-description 'pathname))
          nil)
    ;; Todo: perform one pass, then a full GC, then a final pass to confirm
    ;; it worked. It should be an error if any uninternable symbols remain,
    ;; but at present there are about 7 symbols with referrers.
    (with-package-iterator (iter (list-all-packages) :internal :external)
      (loop (multiple-value-bind (winp symbol accessibility package) (iter)
              (declare (ignore accessibility))
              (unless winp
                (return))
              (when (uninternable-p symbol)
                ;; Uninternable symbols which are referenced by other stuff
                ;; can't disappear from the image, but we don't need to preserve
                ;; their functions, so FMAKUNBOUND them. This doesn't have
                ;; the intended effect if the function shares a code-component
                ;; with non-cold-init lambdas. Though the cold-init function is
                ;; never called post-build, it is not discarded. Also, I suspect
                ;; that the following loop should print nothing, but it does:
                #|
                (sb-vm:map-allocated-objects ;
                (lambda (obj type size) ;
                (declare (ignore size)) ;
                (when (= type sb-vm:code-header-widetag) ;
                (let ((name (sb-c::debug-info-name ;
                (sb-kernel:%code-debug-info obj)))) ;
                (when (and (stringp name) (search "COLD-INIT-FORMS" name)) ;
                (print obj)))))         ;
                :dynamic)               ;
                |#
                (fmakunbound symbol)
                (unintern symbol package))))))
  (sb-int:dohash ((k v) sb-c::*backend-parsed-vops*)
    (declare (ignore k))
    (setf (sb-c::vop-parse-body v) nil))
  ;; Used for inheriting from other VOPs, not needed in the target.
  (setf sb-c::*backend-parsed-vops* (make-hash-table))
  result)


;;; Check for potentially bad format-control strings
(defun scan-format-control-strings ()
  (labels ((possibly-ungood-package-reference (string)
             ;; We want to see nothing SB-package-like at all
             (or (search "sb-" string :test #'char-equal)
                 ;; catch mistakes due to imitating the way things used to be
                 (search "sb!" string :test #'char-equal)))
           (possibly-format-control (string)
             (when (find #\~ string)
               ;; very likely to be a format control if it parses OK.
               ;; Possibly not, but false positives are acceptable.
               (some (lambda (x)
                       (and (typep x 'sb-format::format-directive)
                            (eql (sb-format::directive-character x) #\/)
                            (possibly-ungood-package-reference
                             (subseq string
                                     (sb-format::directive-start x)
                                     (sb-format::directive-end x)))))
                     (ignore-errors
                      (sb-format::%tokenize-control-string
                       string 0 (length string) nil))))))
    (let (wps)
      (sb-vm:map-allocated-objects
       (lambda (obj type size)
         (declare(ignore type size))
         (when (and (stringp obj) (possibly-format-control obj))
           (push (make-weak-pointer obj) wps)))
       :all)
      (when wps
        (dolist (wp wps)
          (sb-int:binding* ((v (weak-pointer-value wp) :exit-if-null))
            (format t "Found string ~S~%" v)))
        (warn "Potential problem with format-control strings.
Please check that all strings which were not recognizable to the compiler
(as the first argument to WARN, etc.) are wrapped in SB-FORMAT:TOKENS"))
      wps)))

;;; If the SB-DOC internal feature is not present, remove any and all
;;; docstrings that snuck in (as can happen with any file compiled in
;;; warm load).
(unless (member :sb-doc sb-impl:+internal-features+)
  (let ((count 0))
    (macrolet ((clear-it (place)
                 `(when ,place
                    ,(if (typep place '(cons (eql sb-int:info)))
                         `(sb-int:clear-info ,@(cdr place))
                         `(setf ,place nil))
                    (incf count))))
      ;; 1. Functions, macros, special operators
      (sb-vm:map-allocated-objects
       (lambda (obj type size)
         (declare (ignore size))
         (case type
          (#.sb-vm:code-header-widetag
           (dotimes (i (sb-kernel:code-n-entries obj))
             (let ((f (sb-kernel:%code-entry-point obj i)))
               (clear-it (sb-kernel:%simple-fun-doc f)))))
          (#.sb-vm:instance-widetag
           (when (typep obj 'class)
             (when (slot-boundp obj 'sb-pcl::%documentation)
               (clear-it (slot-value obj 'sb-pcl::%documentation)))))
          (#.sb-vm:funcallable-instance-widetag
           (when (typep obj 'standard-generic-function)
             (when (slot-boundp obj 'sb-pcl::%documentation)
               (clear-it (slot-value obj 'sb-pcl::%documentation)))))))
       :all)
      ;; 2. Variables, types, and anything else
      (do-all-symbols (s)
        (let ((expander (sb-int:info :setf :expander s)))
          (when (typep expander '(cons t (cons string)))
            (setf (second expander) nil)))
        (dolist (category '(:variable :type :typed-structure))
          (clear-it (sb-int:info category :documentation s)))
        (clear-it (sb-int:info :random-documentation :stuff s))))
    (when (plusp count)
      (format t "~&Removed ~D doc string~:P" count)))
)

#+sb-core-compression
(defun compress-debug-info (code)
  (let ((info (sb-c::%code-debug-info code)))
    (when (typep info 'sb-c::compiled-debug-info)
      (let ((map (sb-c::compiled-debug-info-fun-map info)))
        (when (typep map '(simple-array (unsigned-byte 8) (*)))
          (sb-alien:with-alien ((compress-vector (function int (* char) size-t) :extern "compress_vector"))
            (sb-sys:with-pinned-objects (map)
              (sb-alien:alien-funcall compress-vector
                                      (sb-sys:int-sap (sb-kernel:get-lisp-obj-address map))
                                      (length map)))))))))
(progn
  ;; Remove source forms of compiled-to-memory lambda expressions.
  ;; The disassembler is the major culprit for retention of these,
  ;; but there are others and I don't feel like figuring out where from.
  ;; Globally declaiming EVAL-STORE-SOURCE-FORM 0 would work too,
  ;; but isn't it nice to know that the logic for storing the forms
  ;; actually works? (Yes)
  (sb-vm:map-allocated-objects
   (lambda (obj type size)
     (declare (ignore size))
     (case type
      (#.sb-vm:instance-widetag
       (when (typep obj 'sb-c::core-debug-source)
         (setf (sb-c::core-debug-source-form obj) nil)))
      (#.sb-vm:code-header-widetag
       #+sb-core-compression
       (compress-debug-info obj)
       (dotimes (i (sb-kernel:code-n-entries obj))
         (let ((fun (sb-kernel:%code-entry-point obj i)))
           (when (sb-kernel:%simple-fun-lexpr fun)
             (setf (sb-impl::%simple-fun-source fun)
                   (sb-impl::%simple-fun-doc fun))))))))
   :all)

  ;; Disable the format-control optimizer for ERROR and WARN
  ;; while preserving the argument-checking logic. Technically the optimizer is
  ;; probably ok to leave in, but the spec is ambiguous as to whether
  ;; implicit compile-time transformations on format strings is permitted.
  ;; http://www.lispworks.com/documentation/HyperSpec/Issues/iss170_w.htm
  ;; seems to imply that it is, but I would imagine that users don't expect it.
  (setq sb-c::*optimize-format-strings* nil)

  ;; Fix unknown types in globaldb
  (let ((l nil))
    (do-all-symbols (s)
      (flet ((fixup (kind)
               (multiple-value-bind (type present)
                   (sb-int:info kind :type s)
                 (when (and present
                            (sb-kernel:ctype-p type)
                            (sb-kernel:contains-unknown-type-p type))
                   (setf (sb-int:info kind :type s)
                         (sb-kernel:specifier-type (sb-kernel:type-specifier type)))
                   (push s l)))))
        (fixup :function)
        (fixup :variable)))
    (unless (sb-impl::!c-runtime-noinform-p)
      (let ((*print-pretty* nil)
            (*print-length* nil))
        (format t "~&; Fixed types: ~S~%" (sort l #'string<)))))

  ;; Unintern no-longer-needed stuff before the possible PURIFY in
  ;; SAVE-LISP-AND-DIE.
  #-sb-devel (!unintern-init-only-stuff)


  (do-all-symbols (symbol)
    ;; Don't futz with the header of static symbols.
    ;; Technically LOGIOR-HEADER-BITS can only be used on an OTHER-POINTER-LOWTAG
    ;; objects, so modifying NIL should not ever work, but it's especially wrong
    ;; on ppc64 where OTHER- and LIST- pointer lowtags are 10 bytes apart instead
    ;; of 8, so this was making a random alteration to the header.
    (unless (eq (heap-allocated-p symbol) :static)
      (sb-kernel:logior-header-bits symbol sb-vm::+symbol-initial-core+))

    ;; A symbol whose INFO slot underwent any kind of manipulation
    ;; such that it now has neither properties nor globaldb info,
    ;; can have the slot set back to NIL if it wasn't already.
    (when (and (sb-kernel:symbol-%info symbol) ; "raw" value is something
               ;; but both "cooked" values are empty
               (null (sb-kernel:symbol-dbinfo symbol))
               (null (symbol-plist symbol)))
      (sb-sys:%primitive sb-c:set-slot symbol nil
                         'make-symbol sb-vm:symbol-info-slot sb-vm:other-pointer-lowtag)))
)

(sb-ext:gc :full t)

;;; resetting compilation policy to neutral values in preparation for
;;; SAVE-LISP-AND-DIE as final SBCL core (not in warm.lisp because
;;; SB-C::*POLICY* has file scope)
(setq sb-c::*policy* (copy-structure sb-c::**baseline-policy**))

;;; Adjust READTABLE-BASE-CHAR-PREFERENCE back to the advertised default.
(dolist (rt (list sb-impl::*standard-readtable* *debug-readtable*))
  (setf (readtable-base-char-preference rt) :symbols))
;;; Change the internal constructor's default too.
(let ((dsd sb-kernel::(find 'sb-impl::%readtable-string-preference
                            (dd-slots (find-defstruct-description 'readtable))
                            :key #'dsd-name)))
  (funcall #'(setf slot-value) 'character dsd 'sb-kernel::default))

;;; The system is complete now, all standard functions are
;;; defined.

;;; In case there is xref data for internals, repack it here to
;;; achieve a more compact encoding.
;;;
;;; However, repacking changes
;;; SB-C::**MOST-COMMON-XREF-NAMES-BY-{INDEX,NAME}** thereby changing
;;; the interpretation of xref data written into and loaded from
;;; fasls. Since fasls should be compatible between images originating
;;; from the same SBCL build, REPACK-XREF is of no use after the
;;; target image has been built.
(when (member :sb-xref-for-internals sb-impl:+internal-features+)
  (sb-c::repack-xref :verbose 1))
(fmakunbound 'sb-c::repack-xref)

(load (merge-pathnames "src/code/shaketree" *load-pathname*))
(defun asm-inst-p (symbol)
    ;; Assembler instruction names can't be made external because to do so would
    ;; conflict with common-lisp symbols. Notable examples are PUSH and POP.
    ;; So other criteria must pertain to detecting the important symbols.
    ;; And as we don't need to preserve Lisp macros but do need to retain
    ;; assembler macro instructions, those merit special consideration.
    ;; Additionally, a DEFUN may co-exist with an identically named macro
    ;; instruction. (I'm not happy about it, but that's historical baggage).
    ;; A macro instruction is recognizable to INST by a naming convention
    ;; that is unused for anything else by way of being inconvenient to use -
    ;; a symbol whose print name start with "M:" is a macro instruction.
    (or (get symbol 'sb-disassem::instructions)
        (let ((name (string symbol)))
          (and (> (length name) 2)
               (string= name "M:" :end1 2)))))
(let ((counts
       (mapcar (lambda (x)
                 (list x
                       (sb-impl::package-external-symbol-count x)
                       (sb-impl::package-internal-symbol-count x)))
               (sort (list-all-packages) #'string< :key 'package-name))))
  #-sb-devel
  ;; Remove inline expansions
  (do-symbols (symbol #.(find-package "SB-C"))
    (when (equal (symbol-package symbol) #.(find-package "SB-C"))
      (sb-int:clear-info :function :inlining-data symbol)
      (sb-int:clear-info :function :inlinep symbol)))
  (sb-impl::shake-packages
   ;; Development mode: retain all symbols with any system-related properties
   #+sb-devel
   (lambda (symbol accessibility)
     (declare (ignore accessibility))
     (or (sb-kernel:symbol-%info symbol)
         (sb-kernel:%symbol-function symbol)
         (and (boundp symbol) (not (keywordp symbol)))))
   ;; Release mode: retain all symbols satisfying this intricate test
   #-sb-devel
   (lambda (symbol accessibility)
     (case (symbol-package symbol)
      (#.(find-package "SB-VM")
       (or (eq accessibility :external)
           ;; overapproximate what we need for contribs and tests
           (member symbol `(sb-vm::map-referencing-objects
                            sb-vm::map-stack-references
                            sb-vm::reconstitute-object
                            sb-vm::points-to-arena
                            ;; need this for defining a vop which
                            ;; tests the x86-64 allocation profiler
                            sb-vm::pseudo-atomic
                            ,@(or #+(or x86 x86-64) '(sb-vm::%vector-cas-pair
                                                      sb-vm::%instance-cas-pair
                                                      sb-vm::%cons-cas-pair))
                            ;; Naughty outside-world code uses these.
                            #+x86-64 sb-vm::reg-in-size))
           (let ((s (string symbol))) (and (search "THREAD-" s) (search "-SLOT" s)))
           (search "-OFFSET" (string symbol))
           (search "-TN" (string symbol))))
      (#.(find-package "SB-ALIEN")
       (or (eq accessibility :external) (eq symbol 'sb-alien::alien-callback-p)))
      (#.(mapcar 'find-package
                 '("SB-ASSEM" "SB-BROTHERTREE" "SB-DISASSEM" "SB-FORMAT"
                   "SB-IMPL" "SB-KERNEL" "SB-MOP" "SB-PCL" "SB-PRETTY" "SB-PROFILE"
                   "SB-REGALLOC" "SB-SYS" "SB-UNICODE" "SB-UNIX" "SB-WALKER"))
       ;; Assume all and only external symbols must be retained
         (eq accessibility :external))
      (#.(find-package "SB-C")
       (or (eq accessibility :external)
           (member symbol '(sb-c::tab sb-c::scramble))))
      (#.(find-package "SB-LOOP")
       (or (eq accessibility :external)
           ;; Retain some internals to keep CLSQL working.
           (member symbol '(sb-loop::*loop-epilogue*
                            sb-loop::add-loop-path))))
      (#.(find-package "SB-LOCKLESS")
       (or (eq accessibility :external)
           (member symbol '(sb-lockless::+hash-nbits+)))) ; for a test
      (#.(find-package "SB-THREAD")
       (or (eq accessibility :external)
           ;; for some reason a recent change caused the tree-shaker to drop MAKE-SPINLOCK
           ;; which makes sense. I'm not sure what was rooting the symbol.
           ;; However the :spinlock-api test in threads.impure asserts that spinlock symbols
           ;; exist despite being internal symbols.
           (sb-int:info :function :deprecated symbol)))
      (#.(find-package "SB-FASL")
       ;; Retain +BACKEND-FASL-FILE-IMPLEMENTATION+ and +FASL-FILE-VERSION+
       ;; (and anything else otherwise reachable)
       (and (eq accessibility :external)
            (constantp symbol)))
      (#.(find-package "SB-BIGNUM")
       ;; There are 2 important external symbols for sb-gmp, and 2
       ;; important external symbols for sb-rotate-byte.
       ;; Other externals can disappear.
       (member symbol '(sb-bignum:%allocate-bignum
                        sb-bignum:maximum-bignum-length
                        sb-bignum:bit-index
                        sb-bignum:make-small-bignum)))
      (t
       (if (eq (symbol-package symbol)
               sb-assem::*backend-instruction-set-package*)
           (or (eq accessibility :external) (asm-inst-p symbol))
           ;; By default, retain any symbol with any attachments
           (or (sb-kernel:symbol-%info symbol)
               (sb-kernel:%symbol-function symbol)
               (and (boundp symbol) (not (keywordp symbol))))))))
   :verbose nil :print nil)
  (unintern 'sb-impl::shake-packages 'sb-impl)
  (let ((sum-delta-ext 0)
        (sum-delta-int 0))
    (format t "~&~26TExternal   |    Internal~%")
    (dolist (entry counts)
      (let* ((ext (sb-impl::package-external-symbol-count (car entry)))
             (int (sb-impl::package-internal-symbol-count (car entry)))
             (delta-ext (- ext (cadr entry)))
             (delta-int (- int (caddr entry))))
        (incf sum-delta-ext delta-ext)
        (incf sum-delta-int delta-int)
        (assert (<= delta-ext 0))
        (assert (<= delta-int 0))
        (format t "~20a | ~5d (~5@d) | ~5d (~5@d)~%"
                (package-name (car entry))
                ext delta-ext int delta-int)))
    (format t "~28t (~5@d) |       (~5@d) = (~d)~%"
            sum-delta-ext sum-delta-int
            (+ sum-delta-ext sum-delta-int))))

(scan-format-control-strings)

(macrolet ((def-backward-compatible-sb-c-specials (pairs) ; for UIOP + ASDF
             `(progn
                ,@(mapcar (lambda (pair)
                            `(define-symbol-macro ,(car pair)
                                 (,(sb-int:package-symbolicate "SB-C" "CU-" (cdr pair) "-COUNT")
                                   sb-c::*compilation-unit*)))
                          pairs))))
  ;; coece to a strict boolean
  (define-symbol-macro sb-c::*in-compilation-unit* (not (null sb-c::*compilation-unit*)))
  ;; the "specials" are all SETFable when and only when *IN-COMPILATION-UNIT* is T
  (def-backward-compatible-sb-c-specials
      sb-c::((*aborted-compilation-unit-count* . "ABORTED")
             (*compiler-error-count* . "ERROR")
             (*compiler-warning-count*  . "WARNING")
             (*compiler-style-warning-count* . "STYLE-WARNING")
             (*compiler-note-count* . "NOTE"))))

#+sb-devel
(rename-package "COMMON-LISP" "COMMON-LISP" '("SB-XC" "CL"))

;;; Lock internal packages
#-(and sb-devel
       (not sb-devel-lock-packages))
(dolist (p (list-all-packages))
  (unless (member p (mapcar #'find-package '("KEYWORD" "CL-USER")))
    (sb-ext:lock-package p)))

;;; Clean up stray symbols from the CL-USER package.
(with-package-iterator (iter "CL-USER" :internal :external)
  (loop (multiple-value-bind (winp symbol) (iter)
          (if winp (unintern symbol "CL-USER") (return)))))

(setq sb-c:*compile-to-memory-space* :auto)
(when (find-package "SB-INTERPRETER") (setq sb-ext:*evaluator-mode* :interpret))
#+x86-64 (sb-ext:fold-identical-code :aggressive t :preserve-docstrings t)

;; See comments in 'readtable.lisp'
(setf (readtable-base-char-preference *readtable*) :symbols)