mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
8704f528f2
The issue was that the LINKAGE_TEMP_REG being NL3 was a C argument register, so of course that caused clashing on C call-out, causing problems with run-program. Going back to NL7 didn't work either because it wasn't getting saved before entry into the trampoline. The code here used to have NL7 before the trampoline code was gutted and then restored, so I'm wondering how this ever worked before, because it definitely did. Pick LIP as the TEMP_REG now because not only does it get saved, it's also the least likely thing to get disturbed by clobbering. Fixes #lp2002930. Also remove assembly routine printing because it doesn't need to be part of the build script (unlike the other files in output/ which can't trivially be recovered from a built image), and because not all disassembler printers have been written on riscv yet.
576 lines
27 KiB
Common Lisp
576 lines
27 KiB
Common 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* ((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
|
|
;; 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.
|
|
:CHENEYGC :GENCGC ; GC: pick one and only one
|
|
:ARENA-ALLOCATOR
|
|
;; 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)")))
|
|
(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 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))
|
|
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)))
|
|
)
|
|
|
|
(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
|
|
(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)
|
|
|
|
;; 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.
|
|
(do-all-symbols (symbol)
|
|
(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-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
|
|
;; 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-C" "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-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.
|
|
;; Other externals can disappear.
|
|
(member symbol '(sb-bignum:%allocate-bignum
|
|
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)
|
|
|
|
#+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)
|
|
|
|
|
|
"done with warm.lisp, about to SAVE-LISP-AND-DIE"
|
|
|
|
#|
|
|
This is the actual "name" of a toplevel code component that gets dumped to fasl
|
|
when compiling src/pcl/boot. Not only does it contain a format control string in
|
|
its raw representation, this is a complete and utter waste of time to dump.
|
|
We really ought to try a LOT harder not to produce such garbage metadata:
|
|
|
|
* (progn (terpri)
|
|
(write (sb-c::compiled-debug-fun-toplevel-name
|
|
(elt (sb-c::compiled-debug-info-fun-map *cdi*) 0))
|
|
:level nil :length nil))
|
|
|
|
(SB-C::TOP-LEVEL-FORM
|
|
(LABELS ((WARN-PARSE (SPECIALIZER &OPTIONAL CONDITION)
|
|
(STYLE-WARN "~@<Cannot parse specializer ~S in ~S~@[: ~A~].~@:>"
|
|
SPECIALIZER # CONDITION))
|
|
(WARN-FIND (CONDITION NAME PROTO-GENERIC-FUNCTION PROTO-METHOD)
|
|
(WARN CONDITION :FORMAT-CONTROL
|
|
#<(SIMPLE-BASE-STRING
|
|
228) ~@<Cannot find type for specializer ~
|
|
~/sb-ext:print-symbol-with-prefix/ when executing ~S ~
|
|
for a ~/sb-impl:print-type-specifier/ of a ~
|
|
~/sb-imp... {1003A2BC8F}>
|
|
:FORMAT-ARGUMENTS #))
|
|
(CLASS-NAME-TYPE-SPECIFIER
|
|
(NAME PROTO-GENERIC-FUNCTION PROTO-METHOD &OPTIONAL #)
|
|
(LET #
|
|
#)))
|
|
(DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER/SYMBOL
|
|
(PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER)
|
|
(LET (#)
|
|
(WHEN SPECIALIZER #)))
|
|
(DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER/T
|
|
(PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER)
|
|
(LET (#)
|
|
(WHEN SPECIALIZER #)))
|
|
(DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER/CLASS-EQ-SPECIALIZER
|
|
(PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER)
|
|
(SPECIALIZER-TYPE-SPECIFIER PROTO-GENERIC-FUNCTION PROTO-METHOD
|
|
(SPECIALIZER-CLASS SPECIALIZER)))
|
|
(DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER/EQL-SPECIALIZER
|
|
(PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER)
|
|
(DECLARE (IGNORE PROTO-GENERIC-FUNCTION PROTO-METHOD))
|
|
`(EQL SB-IMPL::COMMA))
|
|
(DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER/STRUCTURE-CLASS
|
|
(PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER)
|
|
(DECLARE (IGNORE PROTO-GENERIC-FUNCTION PROTO-METHOD))
|
|
(CLASS-NAME SPECIALIZER))
|
|
(DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER/SYSTEM-CLASS
|
|
(PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER)
|
|
(DECLARE (IGNORE PROTO-GENERIC-FUNCTION PROTO-METHOD))
|
|
(CLASS-NAME SPECIALIZER))
|
|
(DEFUN REAL-SPECIALIZER-TYPE-SPECIFIER/CLASS
|
|
(PROTO-GENERIC-FUNCTION PROTO-METHOD SPECIALIZER)
|
|
(LET (#)
|
|
(WHEN # #)))))
|
|
|#
|