diff -Nru sbcl-2.1.1/base-target-features.lisp-expr sbcl-2.1.11/base-target-features.lisp-expr --- sbcl-2.1.1/base-target-features.lisp-expr 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/base-target-features.lisp-expr 1970-01-01 00:00:00.000000000 +0000 @@ -1,410 +0,0 @@ -;;;; -*- Lisp -*- - -;;;; tags which are set during the build process and which end up in -;;;; CL:*FEATURES* in the target SBCL, plus some comments about other -;;;; CL:*FEATURES* tags which have special meaning to SBCL or which -;;;; have a special conventional meaning -;;;; -;;;; Note that the recommended way to customize the features of a -;;;; local build of SBCL is not to edit this file, but instead to -;;;; tweak customize-target-features.lisp. (You must create this file -;;;; first; it is not in the SBCL distribution, and is in fact -;;;; explicitly excluded from the distribution in places like -;;;; .cvsignore.) If you define a function in -;;;; customize-target-features.lisp, it will be used to transform the -;;;; target features list after it's read and before it's used. E.g., -;;;; you can use code like this: -;;;; (lambda (list) -;;;; (flet ((enable (x) (pushnew x list)) -;;;; (disable (x) (setf list (remove x list)))) -;;;; #+nil (enable :sb-show) -;;;; (enable :sb-after-xc-core) -;;;; #+nil (disable :sb-doc) -;;;; list)) -;;;; By thus editing a local file (one which is not in the source -;;;; distribution, and which is in .cvsignore) your customizations -;;;; will remain local even if you do things like "cvs update", -;;;; will not show up if you try to submit a patch with "cvs diff", -;;;; and might even stay out of the way if you use other non-CVS-based -;;;; methods to upgrade the files or store your configuration. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -( - ;; - ;; features present in all builds - ;; - - ;; our standard - :ansi-cl :common-lisp - ;; FIXME: Isn't there a :x3jsomething feature which we should set too? - ;; No. CLHS says ":x3j13 [...] A conforming implementation might or - ;; might not contain such a feature." -- CSR, 2002-02-21 - - ;; our dialect - :sbcl - - ;; - ;; features present in this particular build - ;; - - ;; Setting this enables the compilation of documentation strings - ;; from the system sources into the target Lisp executable. - ;; Traditional Common Lisp folk will want this option set. - ;; I (WHN) made it optional because I came to Common Lisp from - ;; C++ through Scheme, so I'm accustomed to asking - ;; Emacs about things that I'm curious about instead of asking - ;; the executable I'm running. - :sb-doc - - ;; Make more debugging information available (for debugging SBCL - ;; itself). If you aren't hacking or troubleshooting SBCL itself, - ;; you probably don't want this set. - ;; - ;; At least two varieties of debugging information are enabled by this - ;; option: - ;; * SBCL is compiled with a higher level of OPTIMIZE DEBUG, so that - ;; the debugger can tell more about the state of the system. - ;; * Various code to print debugging messages, and similar debugging code, - ;; is compiled only when this feature is present. - ;; - ;; Note that the extra information recorded by the compiler at - ;; this higher level of OPTIMIZE DEBUG includes the source location - ;; forms. In order for the debugger to use this information, it has to - ;; re-READ the source file. In an ordinary installation of SBCL, this - ;; re-READing may not work very well, for either of two reasons: - ;; * The sources aren't present on the system in the same location that - ;; they were on the system where SBCL was compiled. - ;; * SBCL is using the standard readtable, without the added hackage - ;; which allows it to handle things like target features. - ;; If you want to be able to use the extra debugging information, - ;; therefore, be sure to keep the sources around, and run with the - ;; readtable configured so that the system sources can be read. - ; :sb-show - - ;; Enable the low level debugger, "ldb", by default. In the ideal - ;; world you would not need this unless you are messing with SBCL at - ;; a very low level (e.g., trying to diagnose GC problems, or trying - ;; to debug assembly code for a port to a new CPU). However, - ;; experience shows that sooner or later everyone lose()'s, in which - ;; case SB-LDB can at least provide an informative backtrace. - :sb-ldb - - ;; This isn't really a target Lisp feature at all, but controls - ;; whether the build process produces an after-xc.core file. This - ;; can be useful for shortening the edit/compile/debug cycle when - ;; you modify SBCL's own source code, as in slam.sh. Otherwise - ;; you don't need it. - ; :sb-after-xc-core - - ;; Enable extra debugging output in the assem.lisp assembler/scheduler - ;; code. (This is the feature which was called :DEBUG in the - ;; original CMU CL code.) - ; :sb-show-assem - - ;; Compile the C runtime with support for low-level debugging output - ;; through FSHOW and FSHOW_SIGNAL. If enabled, this feature allows - ;; users to turn on such debugging output using environment variables at - ;; run-time. - ; :sb-qshow - - ;; Setting this makes SBCL more "fluid", i.e. more amenable to - ;; modification at runtime, by suppressing various INLINE declarations, - ;; compiler macro definitions, FREEZE-TYPE declarations; and by - ;; suppressing various burning-our-ships-behind-us actions after - ;; initialization is complete; and so forth. This tends to clobber the - ;; performance of the system, so unless you have some special need for - ;; this when hacking SBCL itself, you don't want this set. - ; :sb-fluid - - ;; Enable code for collecting statistics on usage of various operations, - ;; useful for performance tuning of the SBCL system itself. This code - ;; is probably pretty stale (having not been tested since the fork from - ;; base CMU CL) but might nonetheless be a useful starting point for - ;; anyone who wants to collect such statistics in the future. - ; :sb-dyncount - - ;; Enable code for detecting concurrent accesses to the same hash-table - ;; in multiple threads. Note that this implementation is currently - ;; (2007-09-11) somewhat too eager: even though in the current implementation - ;; multiple readers are thread safe as long as there are no writers, this - ;; code will also trap multiple readers. - ; :sb-hash-table-debug - - ;; Enabled automatically by make-config.sh for platforms which implement - ;; short vector SIMD intrinsics. - ;; - ; :sb-simd-pack - - ;; Enabled automatically by make-config.sh for platforms which implement - ;; the %READ-CYCLE-COUNTER VOP. Can be disabled manually: affects TIME. - ;; - ;; FIXME: Should this be :SB-CYCLE-COUNTER instead? If so, then the same goes - ;; for :COMPARE-AND-SWAP-VOPS as well, and a bunch of others. Perhaps - ;; built-time convenience features like this should all live in eg. SB-INT - ;; instead? - ;; - ; :cycle-counter - - ;; Build with support for an additional dynamic heap - ;; differing from the main dynamic heap in two ways: - ;; 1. it is guaranteed to reside below 4GB so that all pointers - ;; into it fit in 32 bits. (Only an issue for >32 bit address space) - ;; 2. all objects therein are immovable, and space is reclaimed - ;; by a mark-and-sweep collector. - ;; That combination of aspects potentially allows various efficiencies - ;; in code generation, especially for the x86-64 backend. - ;; The extra space has a fixed size which can only be changed by a rebuild, - ;; and out-of-space conditions are not easily preventable, so the space - ;; is sized rather generously to sidestep the issue. - ;; Additionally, it is assumed that for all objects in the immobile heap, - ;; speed of allocation of those objects is relatively unimportant. - ;; If unexpected performance regressions are observed, - ;; consider disabling this feature and reporting a bug. - ; :immobile-space - - ;; Allocate most functions in the immobile space. - ;; Enabled by default if supported. - ;; The down-side of this feature is that the allocator is significantly - ;; slower than the allocator for movable code. If a particular application - ;; is performance-constrained by speed of creation of compiled functions - ;; (not including closures), the feature can be disabled. - ; :immobile-code - - ;; Combine the layout pointer, instance-length, and widetag of INSTANCE - ;; into a single machine word. This represents a space savings of anywhere - ;; from 4% to 8% in typical applications. (Your mileage may vary). - ; :compact-instance-header - - ;; Peter Van Eynde's increase-bulletproofness code for CMU CL - ;; - ;; Some of the code which was #+high-security before the fork has now - ;; been either made unconditional, deleted, or rewritten into - ;; unrecognizability, but some remains. What remains is not maintained - ;; or tested in current SBCL, but I haven't gone out of my way to - ;; break it, either. - ;; - ; :high-security - ; :high-security-support - - ;; low-level thread primitives support - ;; - ;; As of SBCL 1.0.33.26, threads are part of the default build on - ;; x86oid Linux. Other platforms that support them include - ;; x86oid Darwin, FreeBSD, and Solaris. - ; :sb-thread - - ;; futex support - ;; - ;; While on linux we are able to use futexes for our locking - ;; primitive, on other platforms we don't have this luxury. - ;; - ; :sb-futex - - ;; Support for detection of unportable code (when applied to the - ;; COMMON-LISP package, or SBCL-internal pacakges) or bad-neighbourly - ;; code (when applied to user-level packages), relating to material - ;; alteration to packages or to bindings in symbols in packages. - :sb-package-locks - - ;; Support for the entirety of the 21-bit character space defined by - ;; the Unicode consortium, rather than the classical 8-bit ISO-8859-1 - ;; character set. - :sb-unicode - - ;; Support for a full evaluator that can execute all the CL special - ;; forms, as opposed to the traditional SBCL evaluator which called - ;; COMPILE for everything complicated. - :sb-eval - ;; Support for a different evaluator (interpreter) with improved performance. - ;; You can't have both. - ; :sb-fasteval - - ;; Record source location information for variables, classes, conditions, - ;; packages, etc. Gives much better information on M-. in Slime, but - ;; increases core size by about 100kB. - :sb-source-locations - - ;; Record xref data for SBCL internals. This can be rather useful for - ;; people who want to develop on SBCL itself because it'll make M-? - ;; (slime-edit-uses) work which lists call/expansion/etc. sites. - ;; It'll increase the core size by major 5-6mB, though. - ; :sb-xref-for-internals - - ;; We support package local nicknames. No :sb-prefix here as we vainly - ;; believe our API is worth copying to other implementations as well. - ;; This doesn't affect the build at all, merely declares how things are. - :package-local-nicknames - - ;; This is set in classic CMU CL, and presumably there it means - ;; that the floating point arithmetic implementation - ;; conforms to IEEE's standard. Here it definitely means that the - ;; floating point arithmetic implementation conforms to IEEE's standard. - ;; I (WHN 19990702) haven't tried to verify - ;; that it does conform, but it should at least mostly conform (because - ;; the underlying x86 hardware tries). - :ieee-floating-point - - ;; CMU CL had, and we inherited, code to support 80-bit LONG-FLOAT on the x86 - ;; architecture. Nothing has been done to actively destroy the long float - ;; support, but it hasn't been thoroughly maintained, and needs at least - ;; some maintenance before it will work. (E.g. the LONG-FLOAT-only parts of - ;; genesis are still implemented in terms of unportable CMU CL functions - ;; which are not longer available at genesis time in SBCL.) A deeper - ;; problem is SBCL's bootstrap process implicitly assumes that the - ;; cross-compilation host will be able to make the same distinctions - ;; between floating point types that it does. This assumption is - ;; fundamentally sleazy, even though in practice it's unlikely to break down - ;; w.r.t. distinguishing SINGLE-FLOAT from DOUBLE-FLOAT; it's much more - ;; likely to break down w.r.t. distinguishing DOUBLE-FLOAT from LONG-FLOAT. - ;; Still it's likely to be quite doable to get LONG-FLOAT support working - ;; again, if anyone's sufficiently motivated. - ; :long-float - - ;; Some platforms don't use a 32-bit off_t by default, and thus can't - ;; handle files larger than 2GB. This feature will control whether - ;; we'll try to use platform-specific compilation options to enable a - ;; 64-bit off_t. The intent is for this feature to be automatically - ;; enabled by make-config.sh on platforms where it's needed and known - ;; to work, you shouldn't be enabling it manually. You might however - ;; want to disable it, if you need to pass file descriptors to - ;; foreign code that uses a 32-bit off_t. - ; :largefile - - ;; SBCL has optional support for zlib-based compressed core files. Enable - ;; this feature to compile it in. Obviously, doing so adds a dependency - ;; on zlib. - ; :sb-core-compression - - ;; On certain thread-enabled platforms, synchronization between threads - ;; for the purpose of stopping and starting the world around GC can be - ;; performed using safepoints instead of signals. Enable this feature - ;; to compile with safepoints and to use them for GC. - ;; (Replaces use of SIG_STOP_FOR_GC.) - ; :sb-safepoint - - ;; When compiling with safepoints, the INTERRUPT-THREAD mechanism can - ;; also use safepoints to roll the target thread to a point at which it - ;; can be interrupted safely, instead of using a signal for this - ;; purpose. Enable this feature in addition to :SB-SAFEPOINT to enable - ;; such behaviour. - ;; (Replaces use of SIGURG, except to wake up syscalls.) - ; :sb-thruption - - ;; When compiling with safepoints and thruptions, the TIMER facility - ;; can replace its use of setitimer with a background thread. - ;; (Replaces use of SIGALRM.) - ; :sb-wtimer - - ;; - ;; miscellaneous notes on other things which could have special significance - ;; in the *FEATURES* list - ;; - - ;; Any target feature which affects binary compatibility of fasl files - ;; needs to be recorded in *FEATURES-POTENTIALLY-AFFECTING-FASL-FORMAT* - ;; (elsewhere). - - ;; notes on the :NIL and :IGNORE features: - ;; - ;; #+NIL is used to comment out forms. Occasionally #+IGNORE is used - ;; for this too. So don't use :NIL or :IGNORE as the names of features.. - - ;; notes on :SB-XC and :SB-XC-HOST features (which aren't controlled by this - ;; file, but are instead temporarily pushed onto *FEATURES* or - ;; *TARGET-FEATURES* during some phases of cross-compilation): - ;; - ;; :SB-XC-HOST stands for "cross-compilation host" and is in *FEATURES* - ;; during the first phase of cross-compilation bootstrapping, when the - ;; host Lisp is being used to compile the cross-compiler. - ;; - ;; :SB-XC stands for "cross compiler", and is in *FEATURES* during the second - ;; phase of cross-compilation bootstrapping, when the cross-compiler is - ;; being used to create the first target Lisp. - - ;; notes on the :SB-ASSEMBLING feature (which isn't controlled by - ;; this file): - ;; - ;; This is a flag for whether we're in the assembler. It's - ;; temporarily pushed onto the *FEATURES* list in the setup for - ;; the ASSEMBLE-FILE function. It would be a bad idea - ;; to use it as a name for a permanent feature. - - ;; notes on local features (which are set automatically by the - ;; configuration script, and should not be set here unless you - ;; really, really know what you're doing): - ;; - ;; machine architecture features: - ;; :x86 - ;; any Intel 386 or better, or compatibles like the AMD K6 or K7 - ;; :x86-64 - ;; any x86-64 CPU running in 64-bit mode - ;; :sparc - ;; any Sun UltraSPARC (possibly also non-Ultras -- currently untested) - ;; :ppc - ;; any PowerPC CPU - ;; :ppc64 - ;; 64-bit PowerPC CPU, ISA 2.06 (POWER7) or later - ;; :mips - ;; any MIPS CPU (in little-endian mode with :little-endian) - ;; :arm - ;; an ARM CPU (details yet to be determined) - ;; :arm64 - ;; an ARMv8 AArch64 CPU - ;; :riscv - ;; A RISC-V CPU. - ;; (CMU CL also had a :pentium feature, which affected the definition - ;; of some floating point vops. It was present but not enabled or - ;; documented in the CMU CL code that SBCL is derived from, and has - ;; now been moved to the backend-subfeatures mechanism.) - ;; - ;; properties derived from the machine architecture - ;; - ;; :64-bit - ;; means (= sb-vm:n-word-bits 64) currently true for x86-64, arm64, riscv64, ppc64 - ;; - ;; :64-bit-registers - ;; means (= sb-vm:n-machine-word-bits 64), yet (= sb-vm:n-word-bits 32) currently true for alpha - ;; - ;; :control-stack-grows-downward-not-upward - ;; On the X86, the Lisp control stack grows downward. On the - ;; other supported CPU architectures as of sbcl-0.7.1.40, the - ;; system stack grows upward. - ;; Note that there are other stack-related differences between the - ;; X86 port and the other ports. E.g. on the X86, the Lisp control - ;; stack coincides with the C stack, meaning that on the X86 there's - ;; stuff on the control stack that the Lisp-level debugger doesn't - ;; understand very well. As of sbcl-0.7.1.40 things like that are - ;; just parameterized by #+X86, but it'd probably be better to - ;; use new flags like :CONTROL-STACK-CONTAINS-C-STACK. - ;; - ;; :alien-callbacks - ;; Alien callbacks have been implemented for this platform. - ;; - ;; :compare-and-swap-vops - ;; The backend implements compare-and-swap VOPs. - ;; - ;; operating system features: - ;; :unix = We're intended to run under some Unix-like OS. (This is not - ;; exclusive with the features which indicate which particular - ;; Unix-like OS we're intended to run under.) - ;; :linux = We're intended to run under some version of Linux. - ;; :bsd = We're intended to run under some version of BSD Unix. (This - ;; is not exclusive with the features which indicate which - ;; particular version of BSD we're intended to run under.) - ;; :freebsd = We're intended to run under FreeBSD. - ;; :openbsd = We're intended to run under OpenBSD. - ;; :netbsd = We're intended to run under NetBSD. - ;; :dragonfly = We're intended to run under DragonFly BSD. - ;; :darwin = We're intended to run under Darwin (including MacOS X). - ;; :sunos = We're intended to run under Solaris user environment - ;; with the SunOS kernel. - ;; :win32 = We're intended to under some version of Microsoft Windows. - ) diff -Nru sbcl-2.1.1/benchmarks/grab-mutex.lisp sbcl-2.1.11/benchmarks/grab-mutex.lisp --- sbcl-2.1.1/benchmarks/grab-mutex.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/benchmarks/grab-mutex.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,208 @@ +(in-package sb-thread) + +(sb-ext:defglobal *mutex* (sb-thread:make-mutex)) +(declaim (type mutex *mutex*)) +(sb-ext:defglobal *start-semaphore* nil) +(sb-ext:defglobal *ready-semaphore* nil) + +(defmacro timing (&body body) + `(binding* ((start-real (get-internal-real-time)) + ((thread-start-sec thread-start-nsec) + (sb-unix::clock-gettime sb-unix:clock-thread-cputime-id))) + ,@body + (binding* ((stop-real (get-internal-real-time)) + ((thread-stop-sec thread-stop-nsec) + (sb-unix::clock-gettime sb-unix:clock-thread-cputime-id))) + (values (- stop-real start-real) ; microseconds + (+ (* 1000000 (- thread-stop-sec thread-start-sec)) + (round (- thread-stop-nsec thread-start-nsec) 1000)))))) + +(defmacro timing-test (&body body) + `(let ((m *mutex*) (waste (make-array 100 :element-type 'sb-vm:word))) + (declare (truly-dynamic-extent waste)) + (setq sb-thread::*grab-mutex-calls-performed* 0) + ;; Get all threads to agree on the moment they should start + (sb-thread:signal-semaphore *ready-semaphore*) + (sb-thread:wait-on-semaphore *start-semaphore*) + (macrolet ((do-some-work () + ;; Perform a slightly nontrivial amount of "stuff" + ;; i.e. more than just assigning a variable. + '(dotimes (i (length waste)) + (setf (aref waste i) (logxor (aref waste i) (ash 1 (mod i 64))))))) + (timing ,@body)))) + +;;; Default implementation of WITH-MUTEX +(defun grab-and-release-baseline-nlx-protected (n-iter) + (timing-test + (dotimes (i (the fixnum n-iter)) + (sb-thread:with-mutex (m) + (do-some-work))))) + +;;; Default implementation of grab/release but no interrupt-safety +(defun grab-and-release-baseline-unprotected (n-iter) + (timing-test + (dotimes (i (the fixnum n-iter)) + (sb-thread:grab-mutex m) + (do-some-work) + (sb-thread:release-mutex m)))) + +(defvar *mutexes-held* nil) +(setf (sb-int:info :variable :wired-tls '*mutexes-held*) :always-thread-local + (sb-int:info :variable :always-bound '*mutexes-held*) :always-bound) +(defmacro binding-mutexes-held ((mutex) &body body) + `(dx-let ((*mutexes-held* (cons ,mutex *mutexes-held*))) ,@body)) + +;;; Faster implementation of grab and release +(defun grab-and-release-algo-2 (n-iter) + (timing-test + (dotimes (i (the fixnum n-iter)) + (sb-thread:wait-for-mutex-algorithm-2 m) + (binding-mutexes-held (m) + (do-some-work) + (sb-thread:fast-release-mutex m))))) +;;; Faster implementation, and GRAB- can often avoid a function call +(defun grab-and-release-algo-2+ (n-iter) + (timing-test + (dotimes (i (the fixnum n-iter)) + (sb-thread:wait-for-mutex-2-partial-inline m) + (binding-mutexes-held (m) + (do-some-work) + (sb-thread:fast-release-mutex m))))) +(defun grab-and-release-algo-3 (n-iter) + (timing-test + (dotimes (i (the fixnum n-iter)) + (sb-thread:wait-for-mutex-algorithm-3 m) + (binding-mutexes-held (m) + (do-some-work) + (sb-thread:fast-release-mutex m))))) +(defun grab-and-release-algo-3+ (n-iter) + (timing-test + (dotimes (i (the fixnum n-iter)) + (sb-thread:wait-for-mutex-3-partial-inline m) + (binding-mutexes-held (m) + (do-some-work) + (sb-thread:fast-release-mutex m))))) + +(defun try (n-threads n-iter label testfun) + (let (threads) + (setq *ready-semaphore* (sb-thread:make-semaphore)) + (setq *start-semaphore* (sb-thread:make-semaphore)) + (dotimes (i n-threads) + (push (sb-thread:make-thread testfun :arguments n-iter) + threads)) + ;; Wait until all threads say that they're ready + (sb-thread:wait-on-semaphore *ready-semaphore* :n n-threads) + ;; "Unleash the hounds" + (sb-thread:signal-semaphore *start-semaphore* n-threads) + (let ((sum-real 0) + (sum-cpu 0)) + (dolist (thread threads) + (multiple-value-bind (realtime cputime) + (sb-thread:join-thread thread) + ;;(format t "real: ~5d cpu: ~5d~%" realtime cputime) + (incf sum-real realtime) + (incf sum-cpu cputime))) + (format t "~20a: cpu=(sum=~8d avg=~8d) real=~8d~@[ [~d calls]~]~%" + label + sum-cpu (floor sum-cpu n-threads) + (floor sum-real n-threads) + (let ((c sb-thread::*grab-mutex-calls-performed*)) + (unless (zerop c) c)))))) + +(defun test-n-threads (n) + (try n 100000 "WITH-MUTEX" 'grab-and-release-baseline-nlx-protected) + (try n 100000 "GRAB+RELEASE" 'grab-and-release-baseline-unprotected) + (try n 100000 "ALGO2" 'grab-and-release-algo-2) + (try n 100000 "ALGO2+" 'grab-and-release-algo-2+) + (try n 100000 "ALGO3" 'grab-and-release-algo-3) + (try n 100000 "ALGO3+" 'grab-and-release-algo-3+)) + +#| +* (sb-thread::test-n-threads 5) +WITH-MUTEX : cpu=(sum= 1129410 avg= 225882) real= 251198 +GRAB+RELEASE : cpu=(sum= 1013281 avg= 202656) real= 221599 +ALGO2 : cpu=(sum= 983301 avg= 196660) real= 217599 [480215 calls] +ALGO2+ : cpu=(sum= 906144 avg= 181228) real= 199999 [240760 calls] +ALGO3 : cpu=(sum= 953727 avg= 190745) real= 212000 [482759 calls] +ALGO3+ : cpu=(sum= 893479 avg= 178695) real= 199998 [246538 calls] + +* (sb-thread::test-n-threads 10) +WITH-MUTEX : cpu=(sum= 4744457 avg= 474445) real= 535597 +GRAB+RELEASE : cpu=(sum= 4854507 avg= 485450) real= 544798 +ALGO2 : cpu=(sum= 4168526 avg= 416852) real= 453997 [968121 calls] +ALGO2+ : cpu=(sum= 3720948 avg= 372094) real= 409599 [462061 calls] +ALGO3 : cpu=(sum= 4091659 avg= 409165) real= 444797 [970730 calls] +ALGO3+ : cpu=(sum= 3824551 avg= 382455) real= 418398 [404065 calls] + +* (sb-thread::test-n-threads 15) +WITH-MUTEX : cpu=(sum=12460694 avg= 830712) real= 909595 +GRAB+RELEASE : cpu=(sum=11579420 avg= 771961) real= 835462 +ALGO2 : cpu=(sum= 9343377 avg= 622891) real= 654131 [1463285 calls] +ALGO2+ : cpu=(sum= 8908803 avg= 593920) real= 631996 [571894 calls] +ALGO3 : cpu=(sum= 9262899 avg= 617526) real= 654929 [1458653 calls] +ALGO3+ : cpu=(sum= 8771110 avg= 584740) real= 620264 [539979 calls] + +* (sb-thread::test-n-threads 20) +WITH-MUTEX : cpu=(sum=18373401 avg= 918670) real= 1157394 +GRAB+RELEASE : cpu=(sum=19171438 avg= 958571) real= 1110394 +ALGO2 : cpu=(sum=15958082 avg= 797904) real= 883196 [1947759 calls] +ALGO2+ : cpu=(sum=14531894 avg= 726594) real= 839596 [776184 calls] +ALGO3 : cpu=(sum=16258896 avg= 812944) real= 869995 [1950461 calls] +ALGO3+ : cpu=(sum=15892267 avg= 794613) real= 840197 [719736 calls] + +* (sb-thread::test-n-threads 25) +WITH-MUTEX : cpu=(sum=24908201 avg= 996328) real= 1425273 +GRAB+RELEASE : cpu=(sum=24098405 avg= 963936) real= 1358552 +ALGO2 : cpu=(sum=18334699 avg= 733387) real= 1135194 [2402256 calls] +ALGO2+ : cpu=(sum=18920912 avg= 756836) real= 1095675 [932165 calls] +ALGO3 : cpu=(sum=20350344 avg= 814013) real= 1100794 [2427181 calls] +ALGO3+ : cpu=(sum=19708020 avg= 788320) real= 1051835 [891826 calls] + +* (sb-thread::test-n-threads 30) +WITH-MUTEX : cpu=(sum=29270655 avg= 975688) real= 1725458 +GRAB+RELEASE : cpu=(sum=29194555 avg= 973151) real= 1616391 +ALGO2 : cpu=(sum=25331922 avg= 844397) real= 1331460 [2911750 calls] +ALGO2+ : cpu=(sum=25128049 avg= 837601) real= 1291458 [1111621 calls] +ALGO3 : cpu=(sum=25039192 avg= 834639) real= 1310660 [2912492 calls] +ALGO3+ : cpu=(sum=24520302 avg= 817343) real= 1261327 [1069574 calls] + +* (sb-thread::test-n-threads 35) +WITH-MUTEX : cpu=(sum=35886189 avg= 1025319) real= 1958961 +GRAB+RELEASE : cpu=(sum=32335690 avg= 923876) real= 1894504 +ALGO2 : cpu=(sum=29280055 avg= 836573) real= 1557933 [3395447 calls] +ALGO2+ : cpu=(sum=28854572 avg= 824416) real= 1490965 [1276195 calls] +ALGO3 : cpu=(sum=28764304 avg= 821837) real= 1539534 [3389637 calls] +ALGO3+ : cpu=(sum=27708686 avg= 791676) real= 1467193 [1239603 calls] + +* (sb-thread::test-n-threads 40) +WITH-MUTEX : cpu=(sum=40892193 avg= 1022304) real= 2209987 +GRAB+RELEASE : cpu=(sum=37467476 avg= 936686) real= 2130089 +ALGO2 : cpu=(sum=34310107 avg= 857752) real= 1765091 [3882825 calls] +ALGO2+ : cpu=(sum=33543491 avg= 838587) real= 1711993 [1455625 calls] +ALGO3 : cpu=(sum=32834489 avg= 820862) real= 1724991 [3878370 calls] +ALGO3+ : cpu=(sum=29716033 avg= 742900) real= 1669290 [1378376 calls] + +* (sb-thread::test-n-threads 45) +WITH-MUTEX : cpu=(sum=47760154 avg= 1061336) real= 2463454 +GRAB+RELEASE : cpu=(sum=45402624 avg= 1008947) real= 2385232 +ALGO2 : cpu=(sum=36951436 avg= 821143) real= 1971723 [4363504 calls] +ALGO2+ : cpu=(sum=36382508 avg= 808500) real= 1918567 [1626474 calls] +ALGO3 : cpu=(sum=37765508 avg= 839233) real= 1934301 [4365986 calls] +ALGO3+ : cpu=(sum=37104282 avg= 824539) real= 1842213 [1582110 calls] + +* (sb-thread::test-n-threads 50) +WITH-MUTEX : cpu=(sum=51003010 avg= 1020060) real= 2775826 +GRAB+RELEASE : cpu=(sum=50266070 avg= 1005321) real= 2643187 +ALGO2 : cpu=(sum=42814331 avg= 856286) real= 2179588 [4851758 calls] +ALGO2+ : cpu=(sum=40166972 avg= 803339) real= 2121509 [1795256 calls] +ALGO3 : cpu=(sum=40122437 avg= 802448) real= 2167029 [4843515 calls] +ALGO3+ : cpu=(sum=40284932 avg= 805698) real= 2058550 [1743178 calls] + +* (sb-thread::test-n-threads 55) +WITH-MUTEX : cpu=(sum=55076760 avg= 1001395) real= 3008711 +GRAB+RELEASE : cpu=(sum=56878995 avg= 1034163) real= 2877731 +ALGO2 : cpu=(sum=46343366 avg= 842606) real= 2402168 [5331893 calls] +ALGO2+ : cpu=(sum=43091002 avg= 783472) real= 2330753 [1938588 calls] +ALGO3 : cpu=(sum=45509126 avg= 827438) real= 2342314 [5345695 calls] +ALGO3+ : cpu=(sum=45191331 avg= 821660) real= 2260789 [1909666 calls] +|# diff -Nru sbcl-2.1.1/benchmarks/threads-compile.lisp sbcl-2.1.11/benchmarks/threads-compile.lisp --- sbcl-2.1.1/benchmarks/threads-compile.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/benchmarks/threads-compile.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,243 @@ +;;; This is a stress test of multi-thread garbage collection without +;;; introducing contrived factors into the system such as extra debugging +;;; or manually invoked GC. + +#| + +NB: You need to compile with #+sb-devel +so that compiling "src/compiler/srctran" does not fail quickly. + +Legend: One line per statistic, measured in microsec. One column per thread. +The statistics: + 1. worst observed GC wait time per thread + 2. average GC wait time per thread + 3. total CPU time per thread + +./run-sbcl.sh --dynamic-space-size 4GB +* (load "src/cold/chill") +* (load (compile-file "benchmarks/threads-compile")) + +* (benchmark 4 4) ; 4 threads, 4 iterations each +;; worst-case stop-the-world pause = .528 sec + [ 161289 528922 528972 528953] + [ 67780 100901 93856 99925] + [ 4342694 3875017 4088501 3992092] + +* (benchmark 20 6) ; 20 threads, 6 iterations each +;; worst-case stop-the-world pause = .905 sec +;; but I've seen this parameter pair produce as much as 1.38 sec worst-case pause + [ 853493 905262 904932 904812 904660 904480 905302 904205 904040 904363 905253 905290 905231 903957 903644 903827 903432 903272 903607 905291] + [ 95906 98105 96955 96992 100130 98969 99631 96186 98073 96748 97830 97861 94608 94574 97282 95638 97308 96941 97169 95195] + [ 8638099 7620908 8408132 7783041 7411906 7616439 7550742 7881625 8042876 7627665 7090403 7322993 8996690 8231693 7415837 8477329 7745566 8130082 7640412 7891094] + +* (benchmark 30 4) ; 30 threads, 4 iterations each +;; worst-case stop-the-world pause = 1.59 sec + [ 1589254 1589235 1589236 1589246 1589200 1589244 1589293 1589249 1589258 1589260 1589195 1589517 1589541 1589267 1589454 1589577 1589311 1589311 1589420 1589658 1589638 1589322 1589302 1589262 1426929 1589448 1589644 1589307 1589492 1589577] + [ 131124 133234 134216 132862 134032 133074 131811 133394 134221 133830 133337 135129 133034 131109 133957 130416 128010 133089 128650 131075 134138 133200 130342 132036 126419 133778 132877 135274 132027 132272] + [ 6463084 5699894 6391162 5323400 5510025 5425688 6288613 4886611 5456971 5394043 5564274 5639621 5054329 5722550 5208487 5986264 6858847 5267559 7030543 5811645 5656792 5012832 6000738 5682139 7220169 6433044 5468151 5295718 5333045 5908446] +|# + +(defparameter *gcmetrics-condvar* + (sb-sys:find-dynamic-foreign-symbol-address "gcmetrics_condvar")) +(defparameter *gcmetrics-mutex* + (sb-sys:find-dynamic-foreign-symbol-address "gcmetrics_mutex")) + +(define-alien-routine pthread-mutex-lock int (m unsigned)) +(define-alien-routine pthread-mutex-unlock int (m unsigned)) +(define-alien-routine pthread-cond-wait int (cv unsigned) (m unsigned)) +(define-alien-routine pthread-cond-broadcast int (cv unsigned)) + +(defun thread-gcmetrics (thread) + (sb-thread:with-deathlok (thread c-thread) + (if (= c-thread 0) + (values nil nil nil) + (let ((sap + (sb-sys:sap+ (sb-sys:int-sap c-thread) + (+ (sb-alien:extern-alien "dynamic_values_bytes" (sb-alien:unsigned 32)) + (* 8 8))))) ; interrupt context pointers + (values (sb-sys:sap-ref-64 sap 8) ; avg + (sb-sys:sap-ref-64 sap 16) ; worst + (sb-sys:sap-ref-64 sap 0)))))) ; runtime + +;;; Exercise COMPILE-FILE in many threads, which is representative of a +;;; lispy workload. Any suitable workload should do. +;;; It would be better to have each thread doing a different kind of work, +;;; but I took the easy route. +(defun gc-benchmark (n-threads n-iter) + (let (threads + (running (make-array n-threads :initial-element t)) + (avg-gc-wait (make-array n-threads)) + (worst-gc-wait (make-array n-threads)) + (runtime (make-array n-threads))) + (flet ((work (arg) + (with-open-file (*standard-output* + (format nil "/tmp/foo~d.stdout" arg) + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (let ((*error-output* *standard-output*)) + (dotimes (i n-iter) + (let ((file (format nil "/tmp/foo~d.fasl" arg))) + (compile-file "src/compiler/srctran" + :print nil + :output-file file))))) + (setf (aref running arg) nil) + (pthread-cond-broadcast *gcmetrics-condvar*))) + (dotimes (i n-threads) + (push (sb-thread:make-thread + #'work + :name (format nil "worker~d" i) + :arguments i) + threads))) + (let ((start (get-internal-real-time))) + (assert (= 0 (pthread-mutex-lock *gcmetrics-mutex*))) + (loop + (let ((count (count t running))) + (when (zerop count) (return)) + (assert (= 0 (pthread-cond-wait *gcmetrics-condvar* *gcmetrics-mutex*))) + (let ((i 0)) + (dolist (thread threads) + (multiple-value-bind (avg worst run) (thread-gcmetrics thread) + (when avg + (setf (aref avg-gc-wait i) avg + (aref worst-gc-wait i) worst + (aref runtime i) run))) + (incf i))) + (format t "~D threads:~% [~{~8d~^ ~}]~% [~{~8d~^ ~}]~% [~{~8d~^ ~}]~%" + count + (coerce worst-gc-wait 'list) + (coerce avg-gc-wait 'list) + (coerce runtime 'list)))) + (pthread-mutex-unlock *gcmetrics-mutex*) + (let ((end (get-internal-real-time))) + (format t "~&all done: ~fs~%" + (/ (- end start) internal-time-units-per-second)))))) + +;;; run this with a 16GB dynamic space +(defun allocator-benchmark (n-threads n-iter) + (let (threads (sem (make-semaphore))) + (flet ((work (arg) + (let ((out (format nil "/tmp/out~d.fasl" arg))) + (dotimes (i n-iter) + (compile-file "src/compiler/node" + :print nil :block-compile t :verbose nil + :output-file out) + (signal-semaphore sem)) + (delete-file out)) + (values (sb-vm::current-thread-offset-sap + sb-vm::thread-et-allocator-mutex-acq-slot) + (sb-vm::current-thread-offset-sap + sb-vm::thread-et-find-freeish-page-slot) + (sb-vm::current-thread-offset-sap + sb-vm::thread-et-bzeroing-slot)))) + (dotimes (i n-threads) + (push (make-thread #'work :name (format nil "worker~d" i) :arguments i) + threads) + (sleep .25)) + (setq threads (nreverse threads)) + (macrolet ((intmetric (slot) + `(sap-ref-word sap (ash ,slot sb-vm:word-shift))) + (floatmetric (slot) + `(float (sap-ref-word sap (ash ,slot sb-vm:word-shift))))) + (let ((n-to-go (* n-threads n-iter))) + (loop + ;; Wait for any thread to be done with one COMPILE-FILE + (wait-on-semaphore sem) + (dolist (thread threads) + (with-deathlok (thread c-thread) + (unless (= c-thread 0) + (let* ((sap (int-sap c-thread)) + (divisor (intmetric sb-vm::thread-slow-path-allocs-slot)) + (times + (list (/ (floatmetric sb-vm::thread-et-allocator-mutex-acq-slot) + divisor) + (/ (floatmetric sb-vm::thread-et-find-freeish-page-slot) + divisor) + (/ (floatmetric sb-vm::thread-et-bzeroing-slot) + divisor)))) + (format t "~a: ~a~%" (thread-name thread) times))))) + (terpri) + (when (zerop (decf n-to-go)) (return)))))))) + +#| +typical results: +(ALLOCATOR-BENCHMARK 1 5) + worker0: (330.69366 387.3285 6498.661) + +(ALLOCATOR-BENCHMARK 2 5) + worker0: (330.5141 267.6703 7333.836) + worker1: (228.58601 165.74622 6578.589) + +(ALLOCATOR-BENCHMARK 5 5) + worker0: (690.2581 425.22952 5876.69) + worker1: (710.41406 348.25806 6209.075) + worker2: (839.3615 454.86133 7612.185) + worker3: (885.43054 602.65674 10080.599) + worker4: (610.4866 262.36072 8558.833) + +(ALLOCATOR-BENCHMARK 10 5) + worker0: (1223.6002 430.6594 7850.7573) + worker1: (1330.8501 370.85773 6489.9937) + worker2: (1253.6841 505.19583 5270.5938) + worker3: (1490.959 715.54004 6404.7485) + worker4: (1285.563 418.3966 4903.252) + worker5: (1166.429 367.69632 4751.1025) + worker6: (1516.6385 703.275 5229.6743) + worker7: (1445.5946 435.18625 8682.394) + worker8: (1445.0297 392.44226 6706.816) + worker9: (1356.9069 461.00558 5664.2266) + +(ALLOCATOR-BENCHMARK 20 3) + worker0: (1556.1759 320.41278 7864.225) + worker1: (2484.3042 380.25073 6287.422) + worker2: (2330.8076 518.1103 6229.52) + worker3: (1892.3644 413.4363 6322.3574) + worker4: (2391.721 581.5211 5309.2114) + worker5: (3180.5654 1101.414 5779.844) + worker6: (2621.355 634.3344 4852.1455) + worker7: (2378.809 440.01437 4085.8718) + worker8: (2730.9878 432.23807 3691.8616) + worker9: (2128.9807 376.76605 6020.571) + worker10: (2715.6238 483.9466 7864.9487) + worker11: (2880.8203 445.12094 5770.294) + worker12: (3576.9197 767.5074 6190.4316) + worker13: (3010.8503 437.47897 6542.27) + worker14: (2961.2139 453.69385 6901.6504) + worker15: (3242.9263 513.6723 6050.3047) + worker16: (3760.2107 1017.8271 6511.578) + worker17: (3949.1416 794.4195 5975.102) + worker18: (3443.0042 444.75006 4557.97) + worker19: (3430.517 806.4593 3539.3176) + +(ALLOCATOR-BENCHMARK 30 2) + worker0: (3228.2756 465.13016 8892.34) + worker1: (3792.6448 770.495 7546.6333) + worker2: (3741.0088 856.29407 9156.665) + worker3: (3276.4631 410.84845 8926.436) + worker4: (3618.4817 409.49045 6198.2173) + worker5: (3677.3682 533.64966 6499.718) + worker6: (3326.2502 426.92972 6894.4204) + worker7: (4277.313 497.48938 8042.677) + worker8: (4424.929 515.2159 8480.562) + worker9: (4579.331 646.7453 7944.594) + worker10: (5665.9673 585.96246 9082.217) + worker11: (4093.323 536.14 8263.94) + worker12: (5716.6953 636.16815 6921.578) + worker13: (5787.886 771.44214 4725.5513) + worker14: (7163.328 1685.777 5396.888) + worker15: (5750.1753 584.4418 4869.9063) + worker16: (5826.1787 653.7092 3785.243) + worker17: (6162.1816 760.8072 3882.8232) + worker18: (5333.0513 477.8418 4006.6885) + worker19: (8481.007 597.1158 3250.377) + worker20: (9162.3125 2120.3945 5063.6616) + worker21: (5398.499 643.1221 11578.032) + worker22: (7045.36 1039.0885 5842.894) + worker23: (9666.884 543.9834 4494.3945) + worker24: (9476.041 770.6879 4494.854) + worker25: (4477.0054 348.83954 5587.9424) + worker26: (5616.502 469.45154 5180.7173) + worker27: (10800.295 481.92975 6047.9507) + worker28: (11228.471 606.4268 4192.347) + worker29: (19881.9 996.91534 157.6319) +|# diff -Nru sbcl-2.1.1/build-order.lisp-expr sbcl-2.1.11/build-order.lisp-expr --- sbcl-2.1.1/build-order.lisp-expr 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/build-order.lisp-expr 1970-01-01 00:00:00.000000000 +0000 @@ -1,807 +0,0 @@ -;;;; -*- Lisp -*- - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -;;; a linear ordering of system sources which works both to -;;; compile/load the cross-compiler under the host Common Lisp and -;;; then to cross-compile the complete system into the -;;; under-construction target SBCL -;;; -;;; The keyword flags (:NOT-HOST, :NOT-TARGET, :ASSEM...) are -;;; documented in the code which implements their effects. (As of -;;; sbcl-0.7.10, the comments are on DEFPARAMETER *EXPECTED-STEM-FLAGS* -;;; in src/cold/shared.lisp.) -;;; -;;; Of course, it'd be very nice to have this be a dependency DAG -;;; instead, so that we could do automated incremental recompilation. -;;; But the dependencies are varied and subtle, and it'd be extremely -;;; difficult to extract them automatically, and it'd be extremely -;;; tedious and error-prone to extract them manually, so we don't -;;; extract them. (It would be nice to fix this someday. The most -;;; feasible approach that I can think of would be to make the -;;; dependencies work on a package level, not an individual file -;;; level. Doing it at the package level would make the granularity -;;; coarse enough that it would probably be pretty easy to maintain -;;; the dependency information manually, and the brittleness of the -;;; package system would help make most violations of the declared -;;; dependencies obvious at build time. -- WHN 20000803 - -;;; make-host-n build steps -;;; All uses of #+ and #- reader macros within this file refer to -;;; the chosen target features, and not CL:*FEATURES*. -;;; If you must test a host feature, use "#.(cl:if ..)" syntax. -( - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; miscellaneous - ;; This comes as early as possible, so that we catch the source locations - ;; for everything. - ("src/code/early-source-location" :c-headers) - ("src/code/cross-early" :c-headers :not-target) - - ;; This comes early because it's useful for debugging everywhere. - ("src/code/show" :c-headers) - ("src/compiler/early-constantp" :c-headers) - ("src/code/defsetfs" :not-host) - - ;; Declare all target special variables defined by ANSI - ("src/code/cl-specials" :not-host) - - ;; Things like DX-FLET and AWHEN are available for use in both the - ;; host and target very early. - ("src/code/primordial-extensions" :c-headers) - ("src/code/cold-init-helper-macros" :c-headers) - ("src/code/early-defmethod" :not-host) - - ;; ASAP we replace the host's backquote reader with our own, to avoid leaking - ;; details of the host into the target. This is not a concern in make-host-2 - ;; becase IN-TARGET-CROSS-COMPILATION-MODE assigns the reader macros before - ;; compiling anything. It is, however, a minor concern for make-host-1, but - ;; usually a problem can be exposed only by contrived code / poor style. - ;; e.g. if the host's reader were used when compiling - ;; (EVAL-WHEN (#-SB-XC :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - ;; (DEFUN A-MACRO-HELPER () '`(FOO ,A ,B)) - ;; then A-MACRO-HELPER returns host code, and calling it might be wrong, either - ;; obviously or subtly. If the result is (LIST* 'FOO (LIST* A (LIST B))) - ;; then it's subtly wrong because it might not be the optimal strategy; - ;; whereas if it's (BACKQUOTE (FOO (UNQUOTE A) (UNQUOTE B))) then it's - ;; flat out wrong. At any rate, judicious avoidance of EVAL-WHEN and nested - ;; quasiquotation in 'primordial-extensions' prevents any such issues. - ("src/code/backq") - - ;; It's difficult to be too early with a DECLAIM SPECIAL (or DEFVAR - ;; or whatever) thanks to the sullenly-do-the-wrong-thing semantics - ;; of CL special binding when the variable is undeclared. - ("src/code/globals" :not-host) - - ("src/code/cmacros" :not-host) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; cross-compiler-only replacements for stuff which in target Lisp would be - ;;; supplied by basic machinery - - ("src/code/cross-byte" :c-headers :not-target) - ("src/code/cross-misc" :c-headers :not-target) - ("src/code/cross-char" :c-headers :not-target) - ("src/code/cross-float" :c-headers :not-target) - ("src/code/cross-io" :not-target) - ("src/code/cross-condition" :not-target) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; stuff needed early both in cross-compilation host and in target Lisp - - ("src/code/uncross" :c-headers) - - ("src/code/defbangtype" :c-headers) - ("src/code/early-constants" :c-headers) - - ("src/compiler/deftype" :c-headers) ; on host for SB-XC:DEFTYPE - ("src/compiler/early-lexenv" :c-headers) - ("src/compiler/early-globaldb" :c-headers) - - ;; comes early so that stuff can reason about function names - ("src/code/function-names" :c-headers) - - ;; for various constants e.g. SB-XC:MOST-POSITIVE-FIXNUM and - ;; SB-VM:N-LOWTAG-BITS, needed by "early-objdef" and others - ("src/compiler/generic/parms" :c-headers) - ("src/compiler/target/parms" :c-headers) - ("src/compiler/generic/early-vm" :c-headers) - ("src/compiler/generic/early-objdef" :c-headers) - ("src/code/early-array" :c-headers) ; needs "early-vm" numbers - - ;; This has the BARRIER stuff that the threading support needs, - ;; required for some code in 'early-extensions' - ("src/code/barrier" :not-host) - ("src/code/parse-body" :c-headers) ; on host for PARSE-BODY - ("src/compiler/policy" :c-headers) - #+sb-fasteval ("src/interpreter/basic-env") - ;; PARSE-{UNKNOWN,DEPRECATED}-TYPE and other things should be known - ;; condition subtypes as soon as possible - ("src/code/condition-boot" :not-host) - ("src/code/early-extensions" :c-headers) ; on host for COLLECT, SYMBOLICATE, etc. - ("src/compiler/parse-lambda-list" :c-headers) - ("src/code/restart" :not-host) ; %DEFCONSTANT can bind a restart - - ("src/code/early-cl") - ("src/code/ansi-stream" :not-host) - ("src/code/early-fasl" :c-headers) - - ("src/code/defbangstruct" :c-headers :not-target) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; basic machinery for the target Lisp. Note that although most of these - ;;; files are flagged :NOT-HOST, a few might not be. - - ("src/code/early-print" :not-host) - ("src/code/early-pprint" :not-host) - ("src/code/early-impl" :not-host) - - ("src/code/target-extensions" :not-host) - - ;; Needed before the first use of WITH-SINGLE-PACKAGE-LOCKED-ERROR. - ("src/code/early-package" :not-host) - - ("src/code/early-raw-slots" :c-headers) - - ("src/code/funutils" :not-host) - - ("src/code/maphash" :not-host) - ("src/code/xset" :c-headers) ; for representation of MEMBER type - ;; This needs DEF!STRUCT, and is itself needed early so that structure - ;; accessors and inline functions defined here can be compiled inline - ;; later. (Avoiding full calls increases efficiency) - ("src/code/type-class" :c-headers) - - ("src/code/cas" :not-host) - ("src/compiler/early-c" :c-headers) - ("src/compiler/fun-info" :c-headers) - ("src/pcl/slot-name") ; for calls from 'info-vector' - ;; 'info-vector' is needed at least as early as 'fdefinition' so that the - ;; inlined INFO-VECTOR-FDEFINITION is available to %COERCE-CALLABLE-TO-FUN. - ("src/code/signal" :not-host) - ("src/code/sysmacs" :not-host) - ("src/code/target-lfhash" :not-host) - ("src/compiler/info-vector" :c-headers) - ("src/compiler/globaldb" :c-headers) - ("src/compiler/generic/vm-array" :c-headers) - ("src/code/string-hash" :c-headers) - ("src/code/primordial-type" :c-headers) - ("src/compiler/generic/pinned-objects" :not-host) - ("src/compiler/generic/layout-ids" :c-headers) - ("src/code/early-classoid" :c-headers) - ("src/code/alieneval" :c-headers) - ("src/code/target-error" :not-host) - - ;; "src/code/toplevel.lisp" is the first to need this. It's generated - ;; automatically by grovel_headers.c, i.e. it's not under source control. - ("output/stuff-groveled-from-headers" :not-host) - - ("src/code/cold-error" :not-host) - ;; Define at most one INTERPRETED-FUNCTION type based on target features - #+sb-eval ("src/code/early-full-eval" :not-host) - #+sb-fasteval ("src/interpreter/function" :not-host) - ("src/code/fdefinition" :not-host) - - ("src/code/weak" :not-host) - ;; 'target-alieneval' needs FILL-POINTER which is defined in 'array' - ("src/code/array" :not-host) ; needs WEAK-POINTER-VALUE - ("src/code/debug-var-io") - - ("src/code/target-alieneval" :not-host) - ("src/code/target-c-call" :not-host) - - ;; This needs DEFINE-ALIEN-ROUTINE from target-alieneval. - ("src/code/misc-aliens" :not-host) - - ("src/code/early-float") - ("src/code/pred" :not-host) - - ("src/code/list" :not-host) - ("src/code/seq" :not-host) ; "code/seq" should come after "code/list". - ("src/code/coerce" :not-host) - - ("src/code/huffman") - ("src/code/target-char" :not-host) - ("src/code/target-unicode" :not-host) - ("src/code/string" :not-host) - ("src/code/mipsstrops" :not-host) - - ("src/code/early-time" :c-headers) - ;; 32-bit implementatin of GET-INTERNAL-REAL-TIME needs some thread slots - ("src/code/thread-structs" :c-headers :block-compile) ; some defstructs for genesis - ("src/code/unix" :not-host) - #+win32 ("src/code/win32" :not-host) - - #+android ("src/code/android-os" :not-host) - #+sunos ("src/code/sunos-os" :not-host) - #+bsd ("src/code/bsd-os" :not-host) - #+linux ("src/code/linux-os" :not-host) - #+haiku ("src/code/haiku-os" :not-host) - #+win32 ("src/code/win32-os" :not-host) - - ("src/code/share-vm" :not-host) - - ("src/code/thread" :not-host :block-compile) ; provides *CURRENT-THREAD* for target-signal - ("src/code/target-signal-common" :not-host) - - ("src/code/bignum" :not-host) - ("src/code/number-dispatch" :not-host) - ("src/code/float-inf-nan" :not-host) - ("src/code/numbers" :not-host) - ("src/code/float-trap" :not-host) - ("src/code/float" :not-host) - - ("src/code/irrat" :not-host) - - ("src/code/misc" :c-headers) - - ("src/code/symbol" :not-host) - ("src/code/fd-stream" :not-host) - ("src/code/stream" :not-host) - ("src/code/early-format") - - ("src/code/common-os" :not-host) - - ("src/code/deadline" :not-host) - ("src/code/serve-event" :not-host) - - ("src/code/query" :not-host) - - ("src/code/sort" :not-host) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; compiler (and a few miscellaneous files whose dependencies make it - ;;; convenient to stick them here) - - ("src/compiler/policies") - - ("src/compiler/macros" :c-headers) - - ("src/compiler/constantp" :c-headers) - ("src/compiler/info-functions" :c-headers) - ("src/code/specializable-array" :not-target) - - ("src/compiler/generic/vm-macs" :c-headers) - ("src/compiler/generic/objdef" :c-headers) - - ;; needed by "compiler/vop" - ("src/compiler/sset" :c-headers) - ("src/code/early-type" :c-headers) - ;; sparc-vm and ppc-vm need sc+offset defined to get at internal - ;; error args. This file contains stuff previously in - ;; debug-info.lisp. Should it therefore be :not-host? -- CSR, - ;; 2002-02-05 - ("src/code/sc-offset" :c-headers) - - ;; for e.g. BLOCK-ANNOTATION, needed by "compiler/vop" - ("src/compiler/node" :c-headers :block-compile) - ;; RECONSTRUCT-LEXENV needs types GLOBAL-VAR and DEFINED-FUN - ("src/compiler/lexenv") - - ;; This has ASSEMBLY-UNIT-related stuff needed by core.lisp. - ;; and LABEL, needed by IR2-NLX-INFO - ("src/compiler/early-assem") - - ;; for e.g. PRIMITIVE-TYPE, needed by "vmdef" - ("src/compiler/vop" :c-headers :block-compile) - - ;; needed by "vm" and "primtype" - ("src/compiler/backend" :c-headers) - - ;; for e.g. MAX-VOP-TN-REFS, needed by "meta-vmdef" - ("src/compiler/vmdef" :c-headers) - - ("src/code/defmacro" :c-headers) - ;; for e.g. !DEF-PRIMITIVE-TYPE, needed by primtype.lisp, and - ;; DEFINE-STORAGE-CLASS, needed by target/vm.lisp - ("src/compiler/meta-vmdef" :c-headers) - - ("src/compiler/fixup") ; for DEFSTRUCT FIXUP, needed by generic/core - ("src/compiler/generic/core") ; for CORE-OBJECT-P, needed by x86-64/vm - - ;; for e.g. DESCRIPTOR-REG, needed by primtype.lisp - ("src/compiler/target/vm" :c-headers) - - ;; KLUDGE: I'd prefer to have this done with a "code/target" softlink - ;; instead of a bunch of reader macros. -- WHN 19990308 - #+sparc ("src/code/sparc-vm" :not-host) - #+x86 ("src/code/x86-vm" :not-host) - #+x86-64("src/code/x86-64-vm" :not-host) - #+(or ppc ppc64) ("src/code/ppc-vm" :not-host) - #+mips ("src/code/mips-vm" :not-host) - #+arm ("src/code/arm-vm" :not-host) - #+arm64 ("src/code/arm64-vm" :not-host) - #+riscv ("src/code/riscv-vm" :not-host) - - ;; RANDOM-LAYOUT-CLOS-HASH (in 'class') uses RANDOM, the transform for which - ;; uses GENERATE-RANDOM-EXPR-FOR-POWER-OF-2 which becomes BIG-RANDOM-CHUNK, - ;; which wants to be inlined, and which when inlined becomes RANDOM-CHUNK, - ;; which also wants to be inlined. - ("src/code/target-random" :not-host) - ;; META-FIXME: I think I figured out why this was, and fixed that, - ;; and never removed the following comment, nor can I remember why. - ;; FIXME: Classic CMU CL had (OPTIMIZE (SAFETY 2) (DEBUG 2) declared - ;; around the compilation of "code/class". Why? - ("src/code/class" :c-headers) - ("src/pcl/pre-warm") - ("src/code/target-sxhash" :not-host) ; needs most-fooative-foo-float constants - - ("src/code/debug-info" :c-headers - #.(cl:if (and (cl:find :sb-xc-host cl:*features*) - (cl:find :cmucl cl:*features*)) ; gets fatal warnings in CMUCL 20c - :ignore-failure-p)) - - ("src/code/source-location") - ("src/code/early-class") - ("src/code/condition" :not-host) - #-win32 ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from share-vm - #+win32 ("src/code/target-exception" :not-host) - ("src/code/toplevel" :not-host) - ("src/code/parse-defmacro-errors") - ("src/code/format-directive") - ;; Target-only stuff should usually be compiled late unless it has - ;; compile-time side-effects. This file could probably be later, - ;; but should certainly be no earlier than the definitions - ;; of FORMAT-ERROR and FORMAT-DIRECTIVE. - ("src/code/target-format" :not-host) - - ("src/compiler/generic/primtype" :c-headers) - - ("src/code/host-c-call") - - ;; SB-XC:DEFTYPE is needed in order to compile late-type - ;; in the host Common Lisp, and in order to run, it needs - ;; %COMPILER-DEFTYPE. - ("src/compiler/compiler-deftype" :c-headers) - - ;; These appear here in the build sequence because they require - ;; * the macro INFO, defined in globaldb.lisp, and - ;; * the function PARSE-DEFMACRO, defined in parse-defmacro.lisp, - ;; and because they define - ;; * the function SPECIFIER-TYPE, which is used in fndb.lisp. - ("src/code/late-type" :c-headers) - ;; Compile target-only stuff after all defglobals like *CONS-T-T-TYPE* - ;; and all type-classes are defined. - ("src/code/deftypes-for-target" :c-headers) - - ;; defines IR1-ATTRIBUTES macro, needed by proclaim.lisp - ("src/compiler/knownfun") - - ;; stuff needed by "code/defstruct" - ("src/code/cross-type" :c-headers :not-target) - ("src/compiler/generic/vm-type" :c-headers) - ("src/compiler/proclaim" :c-headers) - - ("src/code/class-init" :c-headers) - - ;; The DEFSTRUCT machinery needs SUBTYPEP, defined in - ;; "code/late-type", and SB-XC:TYPEP, defined in "code/cross-type", - ;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type", - ;; and SB-XC:PROCLAIM, defined in "src/compiler/proclaim" - ("src/code/defstruct" :c-headers) - ("src/code/target-defstruct" :not-host) - - ;; ALIEN-VALUE has to be defined as a class (done by DEFSTRUCT - ;; machinery) before we can set its superclasses here. - ("src/code/alien-type") - - ;; This needs not just the SB-XC:DEFSTRUCT machinery, but also - ;; the TYPE= stuff defined in late-type.lisp, and the - ;; CHECK-FUN-NAME defined in proclaim.lisp. - ("src/code/force-delayed-defbangstructs" :c-headers :not-target) - - ("src/compiler/compiler-error") - - ("src/code/type-init") - ;; Now that the type system is initialized, fix up UNKNOWN types that - ;; have crept in. - ("src/compiler/fixup-type") - - ;; These define target types needed by fndb.lisp. - ("src/code/package" :c-headers) - ("src/code/typep" :not-host) - ("src/code/random") - ("src/code/hash-table" :c-headers) - ("src/code/readtable") - ("src/code/pathname" :not-host) - ("src/code/host-pprint") - - ("src/compiler/fndb") - ("src/compiler/generic/vm-fndb") - - ("src/compiler/generic/late-objdef" :c-headers) - - ("src/compiler/generic/interr" :c-headers) - - ("src/compiler/bit-util") - - ("src/code/load") - - ("src/code/linkage-table" :not-host) - ("src/code/foreign" :not-host) - #+os-provides-dlopen ("src/code/foreign-load" :not-host) - #+(and os-provides-dlopen (not win32)) ("src/code/unix-foreign-load" :not-host) - #+(and os-provides-dlopen win32) ("src/code/win32-foreign-load" :not-host) - - ("src/code/fop") ; needs macros from code/load.lisp - - ("src/compiler/ctype") - ("src/compiler/disassem") - ("src/compiler/assem") - - ;; Compiling this requires fop definitions from code/fop.lisp and - ("src/compiler/dump") - ("src/compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp - - ("src/compiler/ir1report") ; for COMPILER-ERROR-CONTEXT - ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp - ("src/compiler/xref") - ("src/compiler/target-main" :not-host) - ("src/compiler/ir1tran") - ("src/compiler/ir1tran-lambda") - ("src/compiler/ir1-translators" - ;; workaround for ABCL warnings that are not of type STYLE-WARNING: - ;; "Unable to compile function IR1-CONVERT-TAGBODY. Using interpreted form instead." - #.(cl:if (and (cl:find :sb-xc-host cl:*features*) - (cl:find :abcl cl:*features*)) - :ignore-failure-p)) - ("src/compiler/ir1util") - ("src/compiler/callable-args") - ("src/compiler/locall") - ("src/compiler/ir1opt") - ("src/compiler/loop") - - ("src/compiler/ir1final") - ("src/compiler/constraint") - ("src/compiler/equality-constraints") - ("src/compiler/array-tran") - ("src/compiler/seqtran") - ("src/compiler/saptran") - ("src/compiler/modarith") - ("src/compiler/sxhash") - ("src/code/quantifiers") - ("src/compiler/bitops-derive-type") - - ("src/compiler/dfo") - ("src/compiler/dce") - ("src/compiler/checkgen") - - ("src/compiler/tn") - ("src/compiler/life") - - ("src/compiler/debug-dump") - ("src/compiler/generic/utils" :c-headers) - ("src/compiler/fopcompile") - - ("src/assembly/assemfile" :not-target) - - ("src/compiler/target-dstate" :not-host) - ("src/compiler/asm-target/insts") - #+avx2 - ("src/compiler/target/avx2-insts") - ("src/compiler/target/macros") - ("src/compiler/generic/early-type-vops") - - ("src/assembly/target/support") - - ("src/compiler/target/move") - ("src/compiler/target/float") - #+sb-simd-pack - ("src/compiler/target/simd-pack") - #+sb-simd-pack-256 - ("src/compiler/target/simd-pack-256") - ("src/compiler/target/sap") - ("src/compiler/target/system") - ("src/compiler/target/char") - ("src/compiler/target/memory") - ("src/compiler/target/arith" - ;; KLUDGE: for ppc and sparc this appears to be necessary, as it - ;; used to be for array VOPs for X86 until ca. 0.8.5.24 when CSR's - ;; patch for that architecture was finally committed - ;; - ;; old (0.8.5.23) comment on the array-VOP hack for X86: - ;; x Compiling this file for X86 raises alarming warnings of - ;; x the form - ;; x Argument FOO to VOP CHECK-BOUND has SC restriction - ;; x DESCRIPTOR-REG which is not allowed by the operand type: - ;; x (:OR POSITIVE-FIXNUM) - ;; x This seems not to be something that I broke, but rather a "feature" - ;; x inherited from classic CMU CL. (Debian cmucl_2.4.8.deb compiling - ;; x Debian cmucl_2.4.8.tar.gz raises the same warning). Thus, even though - ;; x these warnings are severe enough that they would ordinarily abort - ;; x compilation, for now we blithely ignore them and press on to more - ;; x pressing problems. Someday, though, it would be nice to figure out - ;; x what the problem is and fix it. - #+(or ppc ppc64) :ignore-failure-p) - ("src/compiler/target/pred") - - ;; this file defines the INTERVAL struct which is also used in 'srctran' - ("src/compiler/float-tran") - ;; This is a terrible name for a file that contains type derivers - ;; and IR1 transforms. Maybe split it up into more appropriately named pieces. - ("src/compiler/srctran") - ("src/compiler/generic/vm-tran") - ("src/compiler/generic/late-type-vops") - ("src/compiler/target/type-vops") - ("src/compiler/typetran") - ("src/compiler/generic/vm-typetran") - ("src/code/cross-modular" :not-target) - - ("src/compiler/target/subprim") - ("src/compiler/target/debug") - ("src/compiler/target/c-call") - ("src/compiler/target/cell") - ("src/compiler/target/values") - ("src/compiler/target/alloc") - ("src/compiler/target/call") - ("src/compiler/target/nlx") - ("src/compiler/generic/late-nlx") - ("src/compiler/target/show") - ("src/compiler/target/array") - ("src/compiler/generic/type-error") - ("src/compiler/physenvanal") - - ;; KLUDGE: The assembly files need to be compiled twice: once as - ;; normal lisp files, and once by sb-c:assemble-file. We use a - ;; different suffix / "file type" for the :assem versions to make - ;; sure we don't scribble over anything we shouldn't. - - ("src/assembly/target/assem-rtns") - ("src/assembly/target/array") - ("src/assembly/target/arith") - ("src/assembly/target/alloc") - ;; assembly files are all loaded by genesis before any compiled files. - ("src/assembly/master" :assem :not-host) - - ("src/compiler/pseudo-vops") - - ("src/compiler/aliencomp") - - ("src/compiler/ltv") - ("src/compiler/gtn") - ("src/compiler/ltn") - ("src/compiler/stack") - ("src/compiler/control") - ("src/compiler/entry") - ("src/compiler/ir2tran") - - ("src/compiler/generic/vm-ir2tran") - - ("src/compiler/copyprop") - ("src/compiler/represent") - ("src/compiler/ir2opt") - ("src/compiler/pack") - ("src/compiler/pack-iterative") - ("src/compiler/codegen") - ("src/compiler/debug") - - #+sb-dyncount ("src/compiler/dyncount") - #+sb-dyncount ("src/code/dyncount") - - ("src/code/format-time" :not-host) - - ;; needed by various unhappy-path cases in the cross-compiler - ("src/code/error") - - ;; This wasn't in classic CMU CL "comcom.lisp", but it has some stuff - ;; that Python-as-cross-compiler has turned out to need. - ("src/code/macroexpand") - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; files which depend in some way (directly or indirectly) on stuff - ;; compiled as part of the compiler - - ("src/code/late-extensions") ; needs condition system - ("src/compiler/generic/target-core" :not-host) ; uses stuff from - ; "compiler/generic/core" - - ("src/code/alloc" :not-host) ; needs foo-SPACE-START - ("src/code/simple-fun" :not-host) ; function slot accessors - ("src/code/eval" :not-host) ; uses INFO, wants compiler macro - ("src/code/time" :not-host) - ("src/code/target-package" :not-host) ; needs "code/package" - ("src/code/bignum-random" :not-host) ; needs "code/random" and - ; "code/bignum" - ("src/code/target-hash-table" :not-host) ; needs "code/hash-table" - ("src/code/final" :not-host) - ("src/code/pprint" :not-host) ; defines WITH-PRETTY-STREAM needed by 'print' - ("src/code/reader" :not-host) ; needs "code/readtable" - ("src/code/print" :not-host) - - ("src/code/target-stream" :not-host) ; needs WHITESPACEP from "code/reader" - ("src/code/target-pathname" :not-host) - #-win32 - ("src/code/unix-pathname" :not-host) - #+win32 - ("src/code/win32-pathname" :not-host) - ("src/code/filesys" :not-host) ; needs HOST from "code/pathname" - - ("src/code/target-misc" :not-host) ; dribble-stream, used by "save" - ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" - - ("src/code/early-step") ; target-thread needs *STEP-OUT* - - ("src/code/gc" :not-host) - ("src/code/avltree" :not-host) - ("src/code/target-thread" :not-host) - ("src/code/timer" :not-host) - - ("src/code/error-error" :not-host) ; needs WITH-STANDARD-IO-SYNTAX macro - ;; defines SB-DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp - ("src/code/debug-int" :not-host) - ("src/code/interr" :not-host) - - ("src/code/target-load" :not-host) ; for *assembler-routines*, needed by target-disassem - - ;; target-only assemblerish stuff - ("src/compiler/target-disassem" :not-host) - ("src/compiler/asm-target/target-insts" :not-host) - #+avx2 - ("src/compiler/target/target-avx2-insts" :not-host) - - ("src/code/debug" :not-host) - - ("src/code/octets" :not-host) - ("src/code/external-formats/enc-basic" :not-host) - #+sb-unicode - ("src/code/external-formats/enc-ucs" :not-host) ; win32 needs this - - #+sb-eval - ("src/code/full-eval" :not-host) ; uses INFO, ARG-COUNT-ERROR - - ("src/code/bit-bash" :not-host) ; needs %NEGATE from assembly/target/arith - - #-(or x86 x86-64) - ("src/compiler/generic/sanctify" :not-host) - - ("src/code/cold-init" :not-host) ; needs (SETF EXTERN-ALIEN) macroexpansion - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; target macros and DECLAIMs installed at build-the-cross-compiler time - - ;; FIXME: here? earlier? can probably be as late as possible. Also - ;; maybe call it FORCE-DELAYED-PROCLAIMS? - ("src/compiler/late-proclaim") - - ("src/code/setf") - ("src/code/macros") - ("src/code/loop") - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; other target-code-building stuff which can't be processed until - ;; machinery like SB-XC:DEFMACRO exists - - ("src/code/late-format" ; needs SB-XC:DEFMACRO - #.(cl:if (and (cl:find :sb-xc-host cl:*features*) - (cl:find :cmucl cl:*features*)) ; gets fatal warnings in CMUCL 20c - :ignore-failure-p)) - - ("src/code/late-globaldb" :not-host) - ("src/code/redblack" :not-host) - ;; This file, which must be last, contains sanity-checks of the cross-compile. - ;; The inputs and outputs of certain functions (currently just SXHASH) are stored - ;; in global symbols. Relying on the fact that data are easily dumped as constants - ;; (assuming we don't have a genesis bug), the forms in this file can audit - ;; whether things came out right. - ("src/code/last-file" :not-host)) - -;;; make-target-2 build steps -(("src/code/early-ntrace" ; lets PCL hook into tracing - "src/code/room" ; for MAP-ALLOCATED-OBJECTS - #+immobile-code "src/code/immobile-space" ; needs src/code/room - ;; Delay (re)defining WARN until after remove-static-links works. - ;; The definition in cold-error is good enough for self-build. - "src/code/warm-error" - "src/code/icf" - ;; We re-nickname SB-SEQUENCE as SEQUENCE now. - ;; It could be done in genesis, but not earlier, - ;; since the host has a package of that name. - "src/code/defpackage" - "src/code/target-lflist" - "src/pcl/walk") ; needs DEFPACKAGE - - #+sb-fasteval - ("src/interpreter/macros" - "src/interpreter/checkfuns" - "src/interpreter/env" - "src/interpreter/sexpr" - "src/interpreter/special-forms" - "src/interpreter/eval" - "src/interpreter/debug") - - ("src/code/external-formats/enc-ebcdic") - #+sb-unicode - ("src/code/external-formats/enc-cyr" - "src/code/external-formats/enc-dos" - "src/code/external-formats/enc-iso" - "src/code/external-formats/enc-win" - "src/code/external-formats/enc-mac" - "src/code/external-formats/mb-util" - "src/code/external-formats/enc-cn-tbl" - "src/code/external-formats/enc-cn" - "src/code/external-formats/enc-jpn-tbl" - "src/code/external-formats/enc-jpn" - "src/code/external-formats/enc-utf") - - ("src/code/stubs") - - ;; CLOS, derived from the PCL reference implementation - ;; - ;; This PCL build order is based on a particular - ;; (arbitrary) linearization of the declared build - ;; order dependencies from the old PCL defsys.lisp - ;; dependency database. - ("src/pcl/low" - "src/pcl/macros" - "src/pcl/compiler-support" - "src/pcl/defclass" - "src/pcl/defs" - "src/pcl/fngen" - "src/pcl/wrapper" - "src/pcl/cache" - "src/pcl/dlisp" - "src/pcl/boot" - "src/pcl/vector" - "src/pcl/slots-boot" - "src/pcl/combin" - "src/pcl/dfun" - "src/pcl/ctor" - "src/pcl/braid" - "src/pcl/dlisp3" - "src/pcl/generic-functions" - "src/pcl/slots" - "src/pcl/init" - "src/pcl/std-class" - "src/pcl/cpl" - "src/pcl/fsc" - "src/pcl/methods" - "src/pcl/fixup" - "src/pcl/call-next-method" - "src/pcl/defcombin" - "src/pcl/ctypes" - "src/pcl/env" - "src/pcl/documentation" - "src/pcl/print-object" - "src/pcl/precom1" - "src/pcl/precom2" - "src/code/ntrace") - - ("src/code/setf-funs" - ;; miscellaneous functionality which depends on CLOS - "src/code/late-condition" - - ;; CLOS-level support for the Gray OO streams - ;; extension (which is also supported by various - ;; lower-level hooks elsewhere in the code) - "src/pcl/gray-streams-class" - "src/pcl/gray-streams" - - ;; CLOS-level support for User-extensible sequences. - "src/pcl/sequence" - - ;; other functionality not needed for cold init, moved - ;; to warm init to reduce peak memory requirement in - ;; cold init - "src/code/describe" - - "src/code/describe-policy" - "src/code/inspect" - "src/code/profile" - #+(and x86-64 sb-thread) "src/code/aprof" ; precise allocation profiler - "src/code/step" - "src/code/warm-lib" - "src/code/alien-callback" - "src/code/run-program" - #+win32 "src/code/warm-mswin" - #+gencgc "src/code/traceroot" - - "src/code/repack-xref" - #+cheneygc "src/code/purify" - "src/code/module" - "src/code/save")) diff -Nru sbcl-2.1.1/clean.sh sbcl-2.1.11/clean.sh --- sbcl-2.1.1/clean.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/clean.sh 2021-11-30 16:16:46.000000000 +0000 @@ -32,7 +32,7 @@ $GNUMAKE -I ../src/runtime -s clean cd "$original_pwd" > /dev/null done -( cd ./doc ; sh ./clean.sh ) +( cd ./doc && sh ./clean.sh ) # Within all directories, remove things which don't look like source # files. Some explanations: @@ -118,4 +118,15 @@ -name 'TAGS' -o \ -name 'tags' -o \ -name 'test-passed' -o \ - -name 'local-target-features.lisp-expr' \) -print | xargs rm -fr + -name 'local-target-features.lisp-expr' \) -print | \ + if test -f .cleanignore; then + # Because this file deletes all symlinks, it prevents building + # in a tree of symlinks. Here's a low-tech workaround: have + # whatever tool creates your tree of symlinks enumerate + # relative paths to each one in a file called .cleanignore, + # and this script won't delete them. This .cleanignore file + # doesn't support any wildcards or comments. + awk 'BEGIN{while(getline <".cleanignore"!=0){ign["./" $0]=1}} ign[$0]!=1'; + else + cat; + fi | xargs rm -fr diff -Nru sbcl-2.1.1/common-lisp-exports.lisp-expr sbcl-2.1.11/common-lisp-exports.lisp-expr --- sbcl-2.1.1/common-lisp-exports.lisp-expr 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/common-lisp-exports.lisp-expr 1970-01-01 00:00:00.000000000 +0000 @@ -1,477 +0,0 @@ -;;; symbols exported from the COMMON-LISP package (from the ANSI spec, -;;; section 1.9, figures 1-4 to 1-15, inclusive) -( - ;; from figure 1-4: - "&ALLOW-OTHER-KEYS" "*PRINT-MISER-WIDTH*" - "&AUX" "*PRINT-PPRINT-DISPATCH*" - "&BODY" "*PRINT-PRETTY*" - "&ENVIRONMENT" "*PRINT-RADIX*" - "&KEY" "*PRINT-READABLY*" - "&OPTIONAL" "*PRINT-RIGHT-MARGIN*" - "&REST" "*QUERY-IO*" - "&WHOLE" "*RANDOM-STATE*" - "*" "*READ-BASE*" - "**" "*READ-DEFAULT-FLOAT-FORMAT*" - "***" "*READ-EVAL*" - "*BREAK-ON-SIGNALS*" "*READ-SUPPRESS*" - "*COMPILE-FILE-PATHNAME*" "*READTABLE*" - "*COMPILE-FILE-TRUENAME*" "*STANDARD-INPUT*" - "*COMPILE-PRINT*" "*STANDARD-OUTPUT*" - "*COMPILE-VERBOSE*" "*TERMINAL-IO*" - "*DEBUG-IO*" "*TRACE-OUTPUT*" - "*DEBUGGER-HOOK*" "+" - "*DEFAULT-PATHNAME-DEFAULTS*" "++" - "*ERROR-OUTPUT*" "+++" - "*FEATURES*" "-" - "*GENSYM-COUNTER*" "/" - "*LOAD-PATHNAME*" "//" - "*LOAD-PRINT*" "///" - "*LOAD-TRUENAME*" "/=" - "*LOAD-VERBOSE*" "1+" - "*MACROEXPAND-HOOK*" "1-" - "*MODULES*" "<" - "*PACKAGE*" "<=" - "*PRINT-ARRAY*" "=" - "*PRINT-BASE*" ">" - "*PRINT-CASE*" ">=" - "*PRINT-CIRCLE*" "ABORT" - "*PRINT-ESCAPE*" "ABS" - "*PRINT-GENSYM*" "ACONS" - "*PRINT-LENGTH*" "ACOS" - "*PRINT-LEVEL*" "ACOSH" - "*PRINT-LINES*" "ADD-METHOD" - - ;; from figure 1-5: - "ADJOIN" "ATOM" "BOUNDP" - "ADJUST-ARRAY" "BASE-CHAR" "BREAK" - "ADJUSTABLE-ARRAY-P" "BASE-STRING" "BROADCAST-STREAM" - "ALLOCATE-INSTANCE" "BIGNUM" "BROADCAST-STREAM-STREAMS" - "ALPHA-CHAR-P" "BIT" "BUILT-IN-CLASS" - "ALPHANUMERICP" "BIT-AND" "BUTLAST" - "AND" "BIT-ANDC1" "BYTE" - "APPEND" "BIT-ANDC2" "BYTE-POSITION" - "APPLY" "BIT-EQV" "BYTE-SIZE" - "APROPOS" "BIT-IOR" "CAAAAR" - "APROPOS-LIST" "BIT-NAND" "CAAADR" - "AREF" "BIT-NOR" "CAAAR" - "ARITHMETIC-ERROR" "BIT-NOT" "CAADAR" - "ARITHMETIC-ERROR-OPERANDS" "BIT-ORC1" "CAADDR" - "ARITHMETIC-ERROR-OPERATION" "BIT-ORC2" "CAADR" - "ARRAY" "BIT-VECTOR" "CAAR" - "ARRAY-DIMENSION" "BIT-VECTOR-P" "CADAAR" - "ARRAY-DIMENSION-LIMIT" "BIT-XOR" "CADADR" - "ARRAY-DIMENSIONS" "BLOCK" "CADAR" - "ARRAY-DISPLACEMENT" "BOOLE" "CADDAR" - "ARRAY-ELEMENT-TYPE" "BOOLE-1" "CADDDR" - "ARRAY-HAS-FILL-POINTER-P" "BOOLE-2" "CADDR" - "ARRAY-IN-BOUNDS-P" "BOOLE-AND" "CADR" - "ARRAY-RANK" "BOOLE-ANDC1" "CALL-ARGUMENTS-LIMIT" - "ARRAY-RANK-LIMIT" "BOOLE-ANDC2" "CALL-METHOD" - "ARRAY-ROW-MAJOR-INDEX" "BOOLE-C1" "CALL-NEXT-METHOD" - "ARRAY-TOTAL-SIZE" "BOOLE-C2" "CAR" - "ARRAY-TOTAL-SIZE-LIMIT" "BOOLE-CLR" "CASE" - "ARRAYP" "BOOLE-EQV" "CATCH" - "ASH" "BOOLE-IOR" "CCASE" - "ASIN" "BOOLE-NAND" "CDAAAR" - "ASINH" "BOOLE-NOR" "CDAADR" - "ASSERT" "BOOLE-ORC1" "CDAAR" - "ASSOC" "BOOLE-ORC2" "CDADAR" - "ASSOC-IF" "BOOLE-SET" "CDADDR" - "ASSOC-IF-NOT" "BOOLE-XOR" "CDADR" - "ATAN" "BOOLEAN" "CDAR" - "ATANH" "BOTH-CASE-P" "CDDAAR" - - ;; from figure 1-6: - "CDDADR" "CLEAR-INPUT" "COPY-TREE" - "CDDAR" "CLEAR-OUTPUT" "COS" - "CDDDAR" "CLOSE" "COSH" - "CDDDDR" "CLRHASH" "COUNT" - "CDDDR" "CODE-CHAR" "COUNT-IF" - "CDDR" "COERCE" "COUNT-IF-NOT" - "CDR" "COMPILATION-SPEED" "CTYPECASE" - "CEILING" "COMPILE" "DEBUG" - "CELL-ERROR" "COMPILE-FILE" "DECF" - "CELL-ERROR-NAME" "COMPILE-FILE-PATHNAME" "DECLAIM" - "CERROR" "COMPILED-FUNCTION" "DECLARATION" - "CHANGE-CLASS" "COMPILED-FUNCTION-P" "DECLARE" - "CHAR" "COMPILER-MACRO" "DECODE-FLOAT" - "CHAR-CODE" "COMPILER-MACRO-FUNCTION" "DECODE-UNIVERSAL-TIME" - "CHAR-CODE-LIMIT" "COMPLEMENT" "DEFCLASS" - "CHAR-DOWNCASE" "COMPLEX" "DEFCONSTANT" - "CHAR-EQUAL" "COMPLEXP" "DEFGENERIC" - "CHAR-GREATERP" "COMPUTE-APPLICABLE-METHODS" "DEFINE-COMPILER-MACRO" - "CHAR-INT" "COMPUTE-RESTARTS" "DEFINE-CONDITION" - "CHAR-LESSP" "CONCATENATE" "DEFINE-METHOD-COMBINATION" - "CHAR-NAME" "CONCATENATED-STREAM" "DEFINE-MODIFY-MACRO" - "CHAR-NOT-EQUAL" "CONCATENATED-STREAM-STREAMS" "DEFINE-SETF-EXPANDER" - "CHAR-NOT-GREATERP" "COND" "DEFINE-SYMBOL-MACRO" - "CHAR-NOT-LESSP" "CONDITION" "DEFMACRO" - "CHAR-UPCASE" "CONJUGATE" "DEFMETHOD" - "CHAR/=" "CONS" "DEFPACKAGE" - "CHAR<" "CONSP" "DEFPARAMETER" - "CHAR<=" "CONSTANTLY" "DEFSETF" - "CHAR=" "CONSTANTP" "DEFSTRUCT" - "CHAR>" "CONTINUE" "DEFTYPE" - "CHAR>=" "CONTROL-ERROR" "DEFUN" - "CHARACTER" "COPY-ALIST" "DEFVAR" - "CHARACTERP" "COPY-LIST" "DELETE" - "CHECK-TYPE" "COPY-PPRINT-DISPATCH" "DELETE-DUPLICATES" - "CIS" "COPY-READTABLE" "DELETE-FILE" - "CLASS" "COPY-SEQ" "DELETE-IF" - "CLASS-NAME" "COPY-STRUCTURE" "DELETE-IF-NOT" - "CLASS-OF" "COPY-SYMBOL" "DELETE-PACKAGE" - - ;; from figure 1-7: - "DENOMINATOR" "EQ" - "DEPOSIT-FIELD" "EQL" - "DESCRIBE" "EQUAL" - "DESCRIBE-OBJECT" "EQUALP" - "DESTRUCTURING-BIND" "ERROR" - "DIGIT-CHAR" "ETYPECASE" - "DIGIT-CHAR-P" "EVAL" - "DIRECTORY" "EVAL-WHEN" - "DIRECTORY-NAMESTRING" "EVENP" - "DISASSEMBLE" "EVERY" - "DIVISION-BY-ZERO" "EXP" - "DO" "EXPORT" - "DO*" "EXPT" - "DO-ALL-SYMBOLS" "EXTENDED-CHAR" - "DO-EXTERNAL-SYMBOLS" "FBOUNDP" - "DO-SYMBOLS" "FCEILING" - "DOCUMENTATION" "FDEFINITION" - "DOLIST" "FFLOOR" - "DOTIMES" "FIFTH" - "DOUBLE-FLOAT" "FILE-AUTHOR" - "DOUBLE-FLOAT-EPSILON" "FILE-ERROR" - "DOUBLE-FLOAT-NEGATIVE-EPSILON" "FILE-ERROR-PATHNAME" - "DPB" "FILE-LENGTH" - "DRIBBLE" "FILE-NAMESTRING" - "DYNAMIC-EXTENT" "FILE-POSITION" - "ECASE" "FILE-STREAM" - "ECHO-STREAM" "FILE-STRING-LENGTH" - "ECHO-STREAM-INPUT-STREAM" "FILE-WRITE-DATE" - "ECHO-STREAM-OUTPUT-STREAM" "FILL" - "ED" "FILL-POINTER" - "EIGHTH" "FIND" - "ELT" "FIND-ALL-SYMBOLS" - "ENCODE-UNIVERSAL-TIME" "FIND-CLASS" - "END-OF-FILE" "FIND-IF" - "ENDP" "FIND-IF-NOT" - "ENOUGH-NAMESTRING" "FIND-METHOD" - "ENSURE-DIRECTORIES-EXIST" "FIND-PACKAGE" - "ENSURE-GENERIC-FUNCTION" "FIND-RESTART" - - ;; from figure 1-8: - "FIND-SYMBOL" "GET-INTERNAL-RUN-TIME" - "FINISH-OUTPUT" "GET-MACRO-CHARACTER" - "FIRST" "GET-OUTPUT-STREAM-STRING" - "FIXNUM" "GET-PROPERTIES" - "FLET" "GET-SETF-EXPANSION" - "FLOAT" "GET-UNIVERSAL-TIME" - "FLOAT-DIGITS" "GETF" - "FLOAT-PRECISION" "GETHASH" - "FLOAT-RADIX" "GO" - "FLOAT-SIGN" "GRAPHIC-CHAR-P" - "FLOATING-POINT-INEXACT" "HANDLER-BIND" - "FLOATING-POINT-INVALID-OPERATION" "HANDLER-CASE" - "FLOATING-POINT-OVERFLOW" "HASH-TABLE" - "FLOATING-POINT-UNDERFLOW" "HASH-TABLE-COUNT" - "FLOATP" "HASH-TABLE-P" - "FLOOR" "HASH-TABLE-REHASH-SIZE" - "FMAKUNBOUND" "HASH-TABLE-REHASH-THRESHOLD" - "FORCE-OUTPUT" "HASH-TABLE-SIZE" - "FORMAT" "HASH-TABLE-TEST" - "FORMATTER" "HOST-NAMESTRING" - "FOURTH" "IDENTITY" - "FRESH-LINE" "IF" - "FROUND" "IGNORABLE" - "FTRUNCATE" "IGNORE" - "FTYPE" "IGNORE-ERRORS" - "FUNCALL" "IMAGPART" - "FUNCTION" "IMPORT" - "FUNCTION-KEYWORDS" "IN-PACKAGE" - "FUNCTION-LAMBDA-EXPRESSION" "INCF" - "FUNCTIONP" "INITIALIZE-INSTANCE" - "GCD" "INLINE" - "GENERIC-FUNCTION" "INPUT-STREAM-P" - "GENSYM" "INSPECT" - "GENTEMP" "INTEGER" - "GET" "INTEGER-DECODE-FLOAT" - "GET-DECODED-TIME" "INTEGER-LENGTH" - "GET-DISPATCH-MACRO-CHARACTER" "INTEGERP" - "GET-INTERNAL-REAL-TIME" "INTERACTIVE-STREAM-P" - - ;; from figure 1-9: - "INTERN" "LISP-IMPLEMENTATION-TYPE" - "INTERNAL-TIME-UNITS-PER-SECOND" "LISP-IMPLEMENTATION-VERSION" - "INTERSECTION" "LIST" - "INVALID-METHOD-ERROR" "LIST*" - "INVOKE-DEBUGGER" "LIST-ALL-PACKAGES" - "INVOKE-RESTART" "LIST-LENGTH" - "INVOKE-RESTART-INTERACTIVELY" "LISTEN" - "ISQRT" "LISTP" - "KEYWORD" "LOAD" - "KEYWORDP" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" - "LABELS" "LOAD-TIME-VALUE" - "LAMBDA" "LOCALLY" - "LAMBDA-LIST-KEYWORDS" "LOG" - "LAMBDA-PARAMETERS-LIMIT" "LOGAND" - "LAST" "LOGANDC1" - "LCM" "LOGANDC2" - "LDB" "LOGBITP" - "LDB-TEST" "LOGCOUNT" - "LDIFF" "LOGEQV" - "LEAST-NEGATIVE-DOUBLE-FLOAT" "LOGICAL-PATHNAME" - "LEAST-NEGATIVE-LONG-FLOAT" "LOGICAL-PATHNAME-TRANSLATIONS" - "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LOGIOR" - "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LOGNAND" - "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LOGNOR" - "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LOGNOT" - "LEAST-NEGATIVE-SHORT-FLOAT" "LOGORC1" - "LEAST-NEGATIVE-SINGLE-FLOAT" "LOGORC2" - "LEAST-POSITIVE-DOUBLE-FLOAT" "LOGTEST" - "LEAST-POSITIVE-LONG-FLOAT" "LOGXOR" - "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LONG-FLOAT" - "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LONG-FLOAT-EPSILON" - "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LONG-FLOAT-NEGATIVE-EPSILON" - "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LONG-SITE-NAME" - "LEAST-POSITIVE-SHORT-FLOAT" "LOOP" - "LEAST-POSITIVE-SINGLE-FLOAT" "LOOP-FINISH" - "LENGTH" "LOWER-CASE-P" - "LET" "MACHINE-INSTANCE" - "LET*" "MACHINE-TYPE" - - ;; from figure 1-10: - "MACHINE-VERSION" "MASK-FIELD" - "MACRO-FUNCTION" "MAX" - "MACROEXPAND" "MEMBER" - "MACROEXPAND-1" "MEMBER-IF" - "MACROLET" "MEMBER-IF-NOT" - "MAKE-ARRAY" "MERGE" - "MAKE-BROADCAST-STREAM" "MERGE-PATHNAMES" - "MAKE-CONCATENATED-STREAM" "METHOD" - "MAKE-CONDITION" "METHOD-COMBINATION" - "MAKE-DISPATCH-MACRO-CHARACTER" "METHOD-COMBINATION-ERROR" - "MAKE-ECHO-STREAM" "METHOD-QUALIFIERS" - "MAKE-HASH-TABLE" "MIN" - "MAKE-INSTANCE" "MINUSP" - "MAKE-INSTANCES-OBSOLETE" "MISMATCH" - "MAKE-LIST" "MOD" - "MAKE-LOAD-FORM" "MOST-NEGATIVE-DOUBLE-FLOAT" - "MAKE-LOAD-FORM-SAVING-SLOTS" "MOST-NEGATIVE-FIXNUM" - "MAKE-METHOD" "MOST-NEGATIVE-LONG-FLOAT" - "MAKE-PACKAGE" "MOST-NEGATIVE-SHORT-FLOAT" - "MAKE-PATHNAME" "MOST-NEGATIVE-SINGLE-FLOAT" - "MAKE-RANDOM-STATE" "MOST-POSITIVE-DOUBLE-FLOAT" - "MAKE-SEQUENCE" "MOST-POSITIVE-FIXNUM" - "MAKE-STRING" "MOST-POSITIVE-LONG-FLOAT" - "MAKE-STRING-INPUT-STREAM" "MOST-POSITIVE-SHORT-FLOAT" - "MAKE-STRING-OUTPUT-STREAM" "MOST-POSITIVE-SINGLE-FLOAT" - "MAKE-SYMBOL" "MUFFLE-WARNING" - "MAKE-SYNONYM-STREAM" "MULTIPLE-VALUE-BIND" - "MAKE-TWO-WAY-STREAM" "MULTIPLE-VALUE-CALL" - "MAKUNBOUND" "MULTIPLE-VALUE-LIST" - "MAP" "MULTIPLE-VALUE-PROG1" - "MAP-INTO" "MULTIPLE-VALUE-SETQ" - "MAPC" "MULTIPLE-VALUES-LIMIT" - "MAPCAN" "NAME-CHAR" - "MAPCAR" "NAMESTRING" - "MAPCON" "NBUTLAST" - "MAPHASH" "NCONC" - "MAPL" "NEXT-METHOD-P" - "MAPLIST" "NIL" - - ;; from figure 1-11: - "NINTERSECTION" "PACKAGE-ERROR" - "NINTH" "PACKAGE-ERROR-PACKAGE" - "NO-APPLICABLE-METHOD" "PACKAGE-NAME" - "NO-NEXT-METHOD" "PACKAGE-NICKNAMES" - "NOT" "PACKAGE-SHADOWING-SYMBOLS" - "NOTANY" "PACKAGE-USE-LIST" - "NOTEVERY" "PACKAGE-USED-BY-LIST" - "NOTINLINE" "PACKAGEP" - "NRECONC" "PAIRLIS" - "NREVERSE" "PARSE-ERROR" - "NSET-DIFFERENCE" "PARSE-INTEGER" - "NSET-EXCLUSIVE-OR" "PARSE-NAMESTRING" - "NSTRING-CAPITALIZE" "PATHNAME" - "NSTRING-DOWNCASE" "PATHNAME-DEVICE" - "NSTRING-UPCASE" "PATHNAME-DIRECTORY" - "NSUBLIS" "PATHNAME-HOST" - "NSUBST" "PATHNAME-MATCH-P" - "NSUBST-IF" "PATHNAME-NAME" - "NSUBST-IF-NOT" "PATHNAME-TYPE" - "NSUBSTITUTE" "PATHNAME-VERSION" - "NSUBSTITUTE-IF" "PATHNAMEP" - "NSUBSTITUTE-IF-NOT" "PEEK-CHAR" - "NTH" "PHASE" - "NTH-VALUE" "PI" - "NTHCDR" "PLUSP" - "NULL" "POP" - "NUMBER" "POSITION" - "NUMBERP" "POSITION-IF" - "NUMERATOR" "POSITION-IF-NOT" - "NUNION" "PPRINT" - "ODDP" "PPRINT-DISPATCH" - "OPEN" "PPRINT-EXIT-IF-LIST-EXHAUSTED" - "OPEN-STREAM-P" "PPRINT-FILL" - "OPTIMIZE" "PPRINT-INDENT" - "OR" "PPRINT-LINEAR" - "OTHERWISE" "PPRINT-LOGICAL-BLOCK" - "OUTPUT-STREAM-P" "PPRINT-NEWLINE" - "PACKAGE" "PPRINT-POP" - - ;; from figure 1-12: - "PPRINT-TAB" "READ-CHAR" - "PPRINT-TABULAR" "READ-CHAR-NO-HANG" - "PRIN1" "READ-DELIMITED-LIST" - "PRIN1-TO-STRING" "READ-FROM-STRING" - "PRINC" "READ-LINE" - "PRINC-TO-STRING" "READ-PRESERVING-WHITESPACE" - "PRINT" "READ-SEQUENCE" - "PRINT-NOT-READABLE" "READER-ERROR" - "PRINT-NOT-READABLE-OBJECT" "READTABLE" - "PRINT-OBJECT" "READTABLE-CASE" - "PRINT-UNREADABLE-OBJECT" "READTABLEP" - "PROBE-FILE" "REAL" - "PROCLAIM" "REALP" - "PROG" "REALPART" - "PROG*" "REDUCE" - "PROG1" "REINITIALIZE-INSTANCE" - "PROG2" "REM" - "PROGN" "REMF" - "PROGRAM-ERROR" "REMHASH" - "PROGV" "REMOVE" - "PROVIDE" "REMOVE-DUPLICATES" - "PSETF" "REMOVE-IF" - "PSETQ" "REMOVE-IF-NOT" - "PUSH" "REMOVE-METHOD" - "PUSHNEW" "REMPROP" - "QUOTE" "RENAME-FILE" - "RANDOM" "RENAME-PACKAGE" - "RANDOM-STATE" "REPLACE" - "RANDOM-STATE-P" "REQUIRE" - "RASSOC" "REST" - "RASSOC-IF" "RESTART" - "RASSOC-IF-NOT" "RESTART-BIND" - "RATIO" "RESTART-CASE" - "RATIONAL" "RESTART-NAME" - "RATIONALIZE" "RETURN" - "RATIONALP" "RETURN-FROM" - "READ" "REVAPPEND" - "READ-BYTE" "REVERSE" - - ;; from figure 1-13: - "ROOM" "SIMPLE-BIT-VECTOR" - "ROTATEF" "SIMPLE-BIT-VECTOR-P" - "ROUND" "SIMPLE-CONDITION" - "ROW-MAJOR-AREF" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" - "RPLACA" "SIMPLE-CONDITION-FORMAT-CONTROL" - "RPLACD" "SIMPLE-ERROR" - "SAFETY" "SIMPLE-STRING" - "SATISFIES" "SIMPLE-STRING-P" - "SBIT" "SIMPLE-TYPE-ERROR" - "SCALE-FLOAT" "SIMPLE-VECTOR" - "SCHAR" "SIMPLE-VECTOR-P" - "SEARCH" "SIMPLE-WARNING" - "SECOND" "SIN" - "SEQUENCE" "SINGLE-FLOAT" - "SERIOUS-CONDITION" "SINGLE-FLOAT-EPSILON" - "SET" "SINGLE-FLOAT-NEGATIVE-EPSILON" - "SET-DIFFERENCE" "SINH" - "SET-DISPATCH-MACRO-CHARACTER" "SIXTH" - "SET-EXCLUSIVE-OR" "SLEEP" - "SET-MACRO-CHARACTER" "SLOT-BOUNDP" - "SET-PPRINT-DISPATCH" "SLOT-EXISTS-P" - "SET-SYNTAX-FROM-CHAR" "SLOT-MAKUNBOUND" - "SETF" "SLOT-MISSING" - "SETQ" "SLOT-UNBOUND" - "SEVENTH" "SLOT-VALUE" - "SHADOW" "SOFTWARE-TYPE" - "SHADOWING-IMPORT" "SOFTWARE-VERSION" - "SHARED-INITIALIZE" "SOME" - "SHIFTF" "SORT" - "SHORT-FLOAT" "SPACE" - "SHORT-FLOAT-EPSILON" "SPECIAL" - "SHORT-FLOAT-NEGATIVE-EPSILON" "SPECIAL-OPERATOR-P" - "SHORT-SITE-NAME" "SPEED" - "SIGNAL" "SQRT" - "SIGNED-BYTE" "STABLE-SORT" - "SIGNUM" "STANDARD" - "SIMPLE-ARRAY" "STANDARD-CHAR" - "SIMPLE-BASE-STRING" "STANDARD-CHAR-P" - - ;; from figure 1-14: - "STANDARD-CLASS" "SUBLIS" - "STANDARD-GENERIC-FUNCTION" "SUBSEQ" - "STANDARD-METHOD" "SUBSETP" - "STANDARD-OBJECT" "SUBST" - "STEP" "SUBST-IF" - "STORAGE-CONDITION" "SUBST-IF-NOT" - "STORE-VALUE" "SUBSTITUTE" - "STREAM" "SUBSTITUTE-IF" - "STREAM-ELEMENT-TYPE" "SUBSTITUTE-IF-NOT" - "STREAM-ERROR" "SUBTYPEP" - "STREAM-ERROR-STREAM" "SVREF" - "STREAM-EXTERNAL-FORMAT" "SXHASH" - "STREAMP" "SYMBOL" - "STRING" "SYMBOL-FUNCTION" - "STRING-CAPITALIZE" "SYMBOL-MACROLET" - "STRING-DOWNCASE" "SYMBOL-NAME" - "STRING-EQUAL" "SYMBOL-PACKAGE" - "STRING-GREATERP" "SYMBOL-PLIST" - "STRING-LEFT-TRIM" "SYMBOL-VALUE" - "STRING-LESSP" "SYMBOLP" - "STRING-NOT-EQUAL" "SYNONYM-STREAM" - "STRING-NOT-GREATERP" "SYNONYM-STREAM-SYMBOL" - "STRING-NOT-LESSP" "T" - "STRING-RIGHT-TRIM" "TAGBODY" - "STRING-STREAM" "TAILP" - "STRING-TRIM" "TAN" - "STRING-UPCASE" "TANH" - "STRING/=" "TENTH" - "STRING<" "TERPRI" - "STRING<=" "THE" - "STRING=" "THIRD" - "STRING>" "THROW" - "STRING>=" "TIME" - "STRINGP" "TRACE" - "STRUCTURE" "TRANSLATE-LOGICAL-PATHNAME" - "STRUCTURE-CLASS" "TRANSLATE-PATHNAME" - "STRUCTURE-OBJECT" "TREE-EQUAL" - "STYLE-WARNING" "TRUENAME" - - ;; from figure 1-15: - "TRUNCATE" "VALUES-LIST" - "TWO-WAY-STREAM" "VARIABLE" - "TWO-WAY-STREAM-INPUT-STREAM" "VECTOR" - "TWO-WAY-STREAM-OUTPUT-STREAM" "VECTOR-POP" - "TYPE" "VECTOR-PUSH" - "TYPE-ERROR" "VECTOR-PUSH-EXTEND" - "TYPE-ERROR-DATUM" "VECTORP" - "TYPE-ERROR-EXPECTED-TYPE" "WARN" - "TYPE-OF" "WARNING" - "TYPECASE" "WHEN" - "TYPEP" "WILD-PATHNAME-P" - "UNBOUND-SLOT" "WITH-ACCESSORS" - "UNBOUND-SLOT-INSTANCE" "WITH-COMPILATION-UNIT" - "UNBOUND-VARIABLE" "WITH-CONDITION-RESTARTS" - "UNDEFINED-FUNCTION" "WITH-HASH-TABLE-ITERATOR" - "UNEXPORT" "WITH-INPUT-FROM-STRING" - "UNINTERN" "WITH-OPEN-FILE" - "UNION" "WITH-OPEN-STREAM" - "UNLESS" "WITH-OUTPUT-TO-STRING" - "UNREAD-CHAR" "WITH-PACKAGE-ITERATOR" - "UNSIGNED-BYTE" "WITH-SIMPLE-RESTART" - "UNTRACE" "WITH-SLOTS" - "UNUSE-PACKAGE" "WITH-STANDARD-IO-SYNTAX" - "UNWIND-PROTECT" "WRITE" - "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "WRITE-BYTE" - "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WRITE-CHAR" - "UPGRADED-ARRAY-ELEMENT-TYPE" "WRITE-LINE" - "UPGRADED-COMPLEX-PART-TYPE" "WRITE-SEQUENCE" - "UPPER-CASE-P" "WRITE-STRING" - "USE-PACKAGE" "WRITE-TO-STRING" - "USE-VALUE" "Y-OR-N-P" - "USER-HOMEDIR-PATHNAME" "YES-OR-NO-P" - "VALUES" "ZEROP") diff -Nru sbcl-2.1.1/contrib/asdf/Makefile sbcl-2.1.11/contrib/asdf/Makefile --- sbcl-2.1.1/contrib/asdf/Makefile 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/asdf/Makefile 2021-11-30 16:16:46.000000000 +0000 @@ -1,4 +1,4 @@ -DEST=$(SBCL_PWD)/obj/sbcl-home/contrib/ +DEST=$(SBCL_TOP)/obj/sbcl-home/contrib/ ASDF_FASL=$(DEST)/asdf.fasl UIOP_FASL=$(DEST)/uiop.fasl FASL=$(UIOP_FASL) $(ASDF_FASL) @@ -7,12 +7,12 @@ fasl:: $(UIOP_FASL) $(ASDF_FASL) $(UIOP_FASL):: uiop.lisp ../../output/sbcl.core mkdir -p $(DEST) - $(SBCL) --eval $(FROB_READTABLE) --eval '(compile-file #p"SYS:CONTRIB;ASDF;UIOP.LISP" :print nil :output-file (parse-native-namestring "$@"))' PATH-TABLES maps a namestring to a hashtable which maps ;; source paths to the legacy coverage record for that path in that file, ;; e.g. (1 4 1) -> ((1 4 1) . SB-C::%CODE-COVERAGE-UNMARKED%) - #+(or x86-64 x86) (let ((namestring->path-tables (make-hash-table :test 'equal)) (coverage-records (code-coverage-hashtable)) (n-marks 0)) @@ -133,19 +174,31 @@ (gethash namestring namestring->path-tables) path-lookup-table) (dolist (item legacy-coverage-marks) (setf (gethash (car item) path-lookup-table) item))) + #-arm64 (sb-sys:with-pinned-objects (code) (let ((sap (code-coverage-marks code))) - (dotimes (i (length map)) ; for each recorded mark - (unless (zerop (sb-sys:sap-ref-8 sap i)) + (dotimes (i (length map)) ; for each recorded mark + (when (byte-marked-p (sb-sys:sap-ref-8 sap i)) (incf n-marks) ;; Set the legacy coverage mark for each path it touches - (dolist (path (svref map i)) + ;; One mark byte for x86[-64] corresponds to a union of source paths. + ;; For everybody else, one mark is one path. + (dolist (path #+(or x86 x86-64) (svref map i) + #-(or x86 x86-64) (list (svref map i))) (let ((found (gethash path path-lookup-table))) (if found (rplacd found t) #+nil (warn "Missing coverage entry for ~S in ~S" - path namestring)))))))))) + path namestring)))))))) + #+arm64 + (let ((marks (code-coverage-marks code))) + (dotimes (i (length map)) ; for each recorded mark + (when (byte-marked-p (aref marks i)) + (incf n-marks) + (let ((found (gethash (svref map i) path-lookup-table))) + (if found + (rplacd found t)))))))) (values coverage-records n-marks))) ) ; end MACROLET diff -Nru sbcl-2.1.1/contrib/sb-gmp/gmp.lisp sbcl-2.1.11/contrib/sb-gmp/gmp.lisp --- sbcl-2.1.1/contrib/sb-gmp/gmp.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-gmp/gmp.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -335,13 +335,19 @@ ;;; Utility macros for GMP mpz variable and result declaration and ;;; incarnation of associated SBCL bignums +(declaim (inline allocate-bignum)) +(defun allocate-bignum (size) + (let ((bignum (%allocate-bignum size))) + (dotimes (i size bignum) + (setf (%bignum-ref bignum i) 0)))) + (defmacro with-mpz-results (pairs &body body) (loop for (gres size) in pairs for res = (gensym "RESULT") collect `(when (> ,size sb-kernel:maximum-bignum-length) (error "Size of result exceeds maxim bignum length")) into checks collect `(,gres (struct gmpint)) into declares - collect `(,res (%allocate-bignum ,size)) + collect `(,res (allocate-bignum ,size)) into resinits collect `(setf (slot ,gres 'mp_alloc) (%bignum-length ,res) (slot ,gres 'mp_size) 0 @@ -400,7 +406,7 @@ into resinits collect `(when (> ,size (1- sb-kernel:maximum-bignum-length)) (error "Size of result exceeds maxim bignum length")) into checks - collect `(,res (%allocate-bignum (1+ ,size))) + collect `(,res (allocate-bignum (1+ ,size))) into resallocs collect `(setf ,res (if (minusp (slot ,gres 'mp_size)) ; check for negative result (- (gmp-z-to-bignum (slot ,gres 'mp_d) ,res ,size)) @@ -771,8 +777,8 @@ (blength (denominator b))) 3))) (with-alien ((r (struct gmprat))) - (let ((num (%allocate-bignum size)) - (den (%allocate-bignum size))) + (let ((num (allocate-bignum size)) + (den (allocate-bignum size))) (sb-sys:with-pinned-objects (num den) (setf (slot (slot r 'mp_num) 'mp_size) 0 (slot (slot r 'mp_num) 'mp_alloc) size diff -Nru sbcl-2.1.1/contrib/sb-gmp/sb-gmp.asd sbcl-2.1.11/contrib/sb-gmp/sb-gmp.asd --- sbcl-2.1.1/contrib/sb-gmp/sb-gmp.asd 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-gmp/sb-gmp.asd 2021-11-30 16:16:46.000000000 +0000 @@ -8,7 +8,7 @@ :serial t :components ((:file "gmp")) :perform (load-op :after (o c) (provide 'sb-gmp)) - :in-order-to ((test (test-op "sb-gmp/tests")))) + :in-order-to ((test-op (test-op "sb-gmp/tests")))) (defsystem "sb-gmp/tests" :depends-on ("sb-rt" "sb-gmp") diff -Nru sbcl-2.1.1/contrib/sb-gmp/tests.lisp sbcl-2.1.11/contrib/sb-gmp/tests.lisp --- sbcl-2.1.1/contrib/sb-gmp/tests.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-gmp/tests.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -3,8 +3,10 @@ (in-package "SB-GMP-TESTS") -(defparameter *state* (make-gmp-rstate)) -(rand-seed *state* 1234) +#+sb-gmp +(progn + (defparameter *state* (make-gmp-rstate)) + (rand-seed *state* 1234)) (defmacro defgenerator (name arguments &body body) `(defun ,name ,arguments diff -Nru sbcl-2.1.1/contrib/sb-graph/example/testfile.lisp sbcl-2.1.11/contrib/sb-graph/example/testfile.lisp --- sbcl-2.1.1/contrib/sb-graph/example/testfile.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/example/testfile.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,5 @@ +(defun foo (a b) + (+ a b)) + +(defun bar (b c d) + (* (foo b c) d)) diff -Nru sbcl-2.1.1/contrib/sb-graph/example/trace-1-DEFUNFOO.dot sbcl-2.1.11/contrib/sb-graph/example/trace-1-DEFUNFOO.dot --- sbcl-2.1.1/contrib/sb-graph/example/trace-1-DEFUNFOO.dot 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/example/trace-1-DEFUNFOO.dot 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,367 @@ +digraph { +"{0} COMPONENT [NIL]: ''DEFUN FOO''" -> "{1} CBLOCK [3101743450240528196]"[label="head"]; +"{0} COMPONENT [NIL]: ''DEFUN FOO''" -> "{2} CBLOCK [2506100549378885246]"[label="tail"]; +"{1} CBLOCK [3101743450240528196]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"]; +"{1} CBLOCK [3101743450240528196]" -> "{3} CBLOCK [3432958294353052646]"[label="succ[# 0]"]; +"{1} CBLOCK [3101743450240528196]" -> "{4} CBLOCK [1030293972324225963]"[label="succ[# 1]"]; +"{3} CBLOCK [3432958294353052646]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"]; +"{3} CBLOCK [3432958294353052646]" -> "{5} CBLOCK [3418937811103477267]"[label="succ[# 0]"]; +"{3} CBLOCK [3432958294353052646]" -> "{4} CBLOCK [1030293972324225963]"[label="pred[# 0]"]; +"{3} CBLOCK [3432958294353052646]" -> "{1} CBLOCK [3101743450240528196]"[label="pred[# 1]"]; +"{3} CBLOCK [3432958294353052646]" -> "{6} BIND [3685440732622309514]"[label="start[ctran: BLOCK-START]"color="blue"]; +"{5} CBLOCK [3418937811103477267]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"]; +"{5} CBLOCK [3418937811103477267]" -> "{7} CBLOCK [577634977173467407]"[label="succ[# 0]"]; +"{5} CBLOCK [3418937811103477267]" -> "{3} CBLOCK [3432958294353052646]"[label="pred[# 0]"]; +"{5} CBLOCK [3418937811103477267]" -> "{8} ENTRY [1798174669859920552]: +"[label="start[ctran: BLOCK-START]"color="blue"]; +"{7} CBLOCK [577634977173467407]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"]; +"{7} CBLOCK [577634977173467407]" -> "{2} CBLOCK [2506100549378885246]"[label="succ[# 0]"]; +"{7} CBLOCK [577634977173467407]" -> "{5} CBLOCK [3418937811103477267]"[label="pred[# 0]"]; +"{7} CBLOCK [577634977173467407]" -> "{9} CRETURN [3318805410236664255]: +result-type: #"[label="start[ctran: BLOCK-START]"color="blue"]; +"{2} CBLOCK [2506100549378885246]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"]; +"{2} CBLOCK [2506100549378885246]" -> "{7} CBLOCK [577634977173467407]"[label="pred[# 0]"]; +"{9} CRETURN [3318805410236664255]: +result-type: #" -> "{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL"[label="lambda"]; +"{9} CRETURN [3318805410236664255]: +result-type: #" -> "{B} LVAR [3332062336230889072]: +%derived-type: NIL +dynamic-extent: NIL"[label="result"]; +"{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL" -> "{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL"[label="home"]; +"{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL" -> "{C} LAMBDA-VAR [427626644569905684]: +arg-info: NIL +flags: 0"[label="vars[# 0]"]; +"{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL" -> "{D} LAMBDA-VAR [2146378094944416105]: +arg-info: NIL +flags: 0"[label="vars[# 1]"]; +"{C} LAMBDA-VAR [427626644569905684]: +arg-info: NIL +flags: 0" -> "{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL"[label="home"]; +"{D} LAMBDA-VAR [2146378094944416105]: +arg-info: NIL +flags: 0" -> "{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL"[label="home"]; +"{B} LVAR [3332062336230889072]: +%derived-type: NIL +dynamic-extent: NIL" -> "{9} CRETURN [3318805410236664255]: +result-type: #"[label="dest"color="brown"]; +"{B} LVAR [3332062336230889072]: +%derived-type: NIL +dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #"[label="uses"]; +"{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #" -> "{F} LVAR [880522709123618192]: +%derived-type: # +dynamic-extent: NIL"[label="fun"]; +"{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #" -> "{10} LVAR [1971775294085688999]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #" -> "{11} LVAR [2437848309170464037]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{F} LVAR [880522709123618192]: +%derived-type: # +dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{F} LVAR [880522709123618192]: +%derived-type: # +dynamic-extent: NIL" -> "{12} REF [2322685304030638494]: +derived-type: #"[label="uses"]; +"{12} REF [2322685304030638494]: +derived-type: #" -> "{13} NOT SUPPORTED YET: + # + :DEFINED-TYPE # + :WHERE-FROM :DECLARED + :KIND :GLOBAL-FUNCTION {1001D90B33}>"[label="leaf"]; +"{12} REF [2322685304030638494]: +derived-type: #" -> "{14} REF [2214161050784690650]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{12} REF [2322685304030638494]: +derived-type: #" -> "{F} LVAR [880522709123618192]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{14} REF [2214161050784690650]: +derived-type: #" -> "{C} LAMBDA-VAR [427626644569905684]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{14} REF [2214161050784690650]: +derived-type: #" -> "{15} REF [1478297276934534521]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{14} REF [2214161050784690650]: +derived-type: #" -> "{10} LVAR [1971775294085688999]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{15} REF [1478297276934534521]: +derived-type: #" -> "{D} LAMBDA-VAR [2146378094944416105]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{15} REF [1478297276934534521]: +derived-type: #" -> "{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{15} REF [1478297276934534521]: +derived-type: #" -> "{11} LVAR [2437848309170464037]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{11} LVAR [2437848309170464037]: +%derived-type: # +dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{11} LVAR [2437848309170464037]: +%derived-type: # +dynamic-extent: NIL" -> "{15} REF [1478297276934534521]: +derived-type: #"[label="uses"]; +"{10} LVAR [1971775294085688999]: +%derived-type: # +dynamic-extent: NIL" -> "{E} COMBINATION [4470851417157717636]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{10} LVAR [1971775294085688999]: +%derived-type: # +dynamic-extent: NIL" -> "{14} REF [2214161050784690650]: +derived-type: #"[label="uses"]; +"{8} ENTRY [1798174669859920552]: +" -> "{16} NOT SUPPORTED YET: + # {1001D90A13}>"[label="cleanup"]; +"{8} ENTRY [1798174669859920552]: +" -> "{12} REF [2322685304030638494]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{8} ENTRY [1798174669859920552]: +" -> "{8} ENTRY [1798174669859920552]: +"[label="prev[ctran: BLOCK-START]"color="blue"]; +"{4} CBLOCK [1030293972324225963]" -> "{0} COMPONENT [NIL]: ''DEFUN FOO''"[label="component"]; +"{4} CBLOCK [1030293972324225963]" -> "{3} CBLOCK [3432958294353052646]"[label="succ[# 0]"]; +"{4} CBLOCK [1030293972324225963]" -> "{1} CBLOCK [3101743450240528196]"[label="pred[# 0]"]; +"{4} CBLOCK [1030293972324225963]" -> "{17} BIND [831277122367414297]"[label="start[ctran: BLOCK-START]"color="blue"]; +"{17} BIND [831277122367414297]" -> "{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="lambda"]; +"{17} BIND [831277122367414297]" -> "{19} REF [3619795511931107142]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="green"]; +"{17} BIND [831277122367414297]" -> "{17} BIND [831277122367414297]"[label="prev[ctran: BLOCK-START]"color="red"]; +"{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{1A} LAMBDA-VAR [1619988245174222653]: +arg-info: NIL +flags: 1"[label="vars[# 0]"]; +"{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{1B} LAMBDA-VAR [1302633028662760541]: +arg-info: NIL +flags: 0"[label="vars[# 1]"]; +"{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{1C} LAMBDA-VAR [4271800902626008186]: +arg-info: NIL +flags: 0"[label="vars[# 2]"]; +"{1A} LAMBDA-VAR [1619988245174222653]: +arg-info: NIL +flags: 1" -> "{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{1B} LAMBDA-VAR [1302633028662760541]: +arg-info: NIL +flags: 0" -> "{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{1C} LAMBDA-VAR [4271800902626008186]: +arg-info: NIL +flags: 0" -> "{18} CLAMBDA [2262455371626719506]: +%debug-name: (XEP FOO) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{19} REF [3619795511931107142]: +derived-type: #" -> "{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL"[label="leaf"]; +"{19} REF [3619795511931107142]: +derived-type: #" -> "{1D} REF [255745217795967635]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{19} REF [3619795511931107142]: +derived-type: #" -> "{1E} LVAR [2622378942754528345]: +%derived-type: NIL +dynamic-extent: NIL"[label="lvar"]; +"{1D} REF [255745217795967635]: +derived-type: #" -> "{1B} LAMBDA-VAR [1302633028662760541]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{1D} REF [255745217795967635]: +derived-type: #" -> "{1F} REF [3667387203345186464]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{1D} REF [255745217795967635]: +derived-type: #" -> "{20} LVAR [2092324786633111792]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{1F} REF [3667387203345186464]: +derived-type: #" -> "{1C} LAMBDA-VAR [4271800902626008186]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{1F} REF [3667387203345186464]: +derived-type: #" -> "{21} COMBINATION [3204626948301471823]: +kind: LOCAL +info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{1F} REF [3667387203345186464]: +derived-type: #" -> "{22} LVAR [4442925413727114980]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{21} COMBINATION [3204626948301471823]: +kind: LOCAL +info: LOCAL" -> "{1E} LVAR [2622378942754528345]: +%derived-type: NIL +dynamic-extent: NIL"[label="fun"]; +"{21} COMBINATION [3204626948301471823]: +kind: LOCAL +info: LOCAL" -> "{20} LVAR [2092324786633111792]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{21} COMBINATION [3204626948301471823]: +kind: LOCAL +info: LOCAL" -> "{22} LVAR [4442925413727114980]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{1E} LVAR [2622378942754528345]: +%derived-type: NIL +dynamic-extent: NIL" -> "{21} COMBINATION [3204626948301471823]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{1E} LVAR [2622378942754528345]: +%derived-type: NIL +dynamic-extent: NIL" -> "{19} REF [3619795511931107142]: +derived-type: #"[label="uses"]; +"{20} LVAR [2092324786633111792]: +%derived-type: # +dynamic-extent: NIL" -> "{21} COMBINATION [3204626948301471823]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{20} LVAR [2092324786633111792]: +%derived-type: # +dynamic-extent: NIL" -> "{1D} REF [255745217795967635]: +derived-type: #"[label="uses"]; +"{22} LVAR [4442925413727114980]: +%derived-type: # +dynamic-extent: NIL" -> "{21} COMBINATION [3204626948301471823]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{22} LVAR [4442925413727114980]: +%derived-type: # +dynamic-extent: NIL" -> "{1F} REF [3667387203345186464]: +derived-type: #"[label="uses"]; +"{6} BIND [3685440732622309514]" -> "{A} CLAMBDA [1548640143404685150]: +%debug-name: NIL +source-name: FOO +kind: NIL"[label="lambda"]; +"{6} BIND [3685440732622309514]" -> "{6} BIND [3685440732622309514]"[label="prev[ctran: BLOCK-START]"color="red"]; +} \ No newline at end of file diff -Nru sbcl-2.1.1/contrib/sb-graph/example/trace-2-toplevelform.dot sbcl-2.1.11/contrib/sb-graph/example/trace-2-toplevelform.dot --- sbcl-2.1.1/contrib/sb-graph/example/trace-2-toplevelform.dot 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/example/trace-2-toplevelform.dot 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,128 @@ +digraph { +"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{1} CBLOCK [1943264620861609727]"[label="head"]; +"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{2} CBLOCK [1731306899775915608]"[label="tail"]; +"{1} CBLOCK [1943264620861609727]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"]; +"{1} CBLOCK [1943264620861609727]" -> "{3} CBLOCK [3908410932650914907]"[label="succ[# 0]"]; +"{3} CBLOCK [3908410932650914907]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"]; +"{3} CBLOCK [3908410932650914907]" -> "{2} CBLOCK [1731306899775915608]"[label="succ[# 0]"]; +"{3} CBLOCK [3908410932650914907]" -> "{1} CBLOCK [1943264620861609727]"[label="pred[# 0]"]; +"{3} CBLOCK [3908410932650914907]" -> "{4} BIND [3628153076315219959]"[label="start[ctran: BLOCK-START]"color="blue"]; +"{2} CBLOCK [1731306899775915608]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"]; +"{2} CBLOCK [1731306899775915608]" -> "{3} CBLOCK [3908410932650914907]"[label="pred[# 0]"]; +"{4} BIND [3628153076315219959]" -> "{5} CLAMBDA [1883614179857431325]: +%debug-name: (TOP-LEVEL-FORM + (%DEFUN 'FOO + (NAMED-LAMBDA FOO + (A B) + (DECLARE (TOP-LEVEL-FORM)) + (BLOCK FOO (+ A B))))) +source-name: .ANONYMOUS. +kind: TOPLEVEL"[label="lambda"]; +"{4} BIND [3628153076315219959]" -> "{6} REF [1814276436352168607]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="green"]; +"{4} BIND [3628153076315219959]" -> "{4} BIND [3628153076315219959]"[label="prev[ctran: BLOCK-START]"color="red"]; +"{5} CLAMBDA [1883614179857431325]: +%debug-name: (TOP-LEVEL-FORM + (%DEFUN 'FOO + (NAMED-LAMBDA FOO + (A B) + (DECLARE (TOP-LEVEL-FORM)) + (BLOCK FOO (+ A B))))) +source-name: .ANONYMOUS. +kind: TOPLEVEL" -> "{5} CLAMBDA [1883614179857431325]: +%debug-name: (TOP-LEVEL-FORM + (%DEFUN 'FOO + (NAMED-LAMBDA FOO + (A B) + (DECLARE (TOP-LEVEL-FORM)) + (BLOCK FOO (+ A B))))) +source-name: .ANONYMOUS. +kind: TOPLEVEL"[label="home"]; +"{6} REF [1814276436352168607]: +derived-type: #" -> "{7} NOT SUPPORTED YET: + # + :DEFINED-TYPE # + :WHERE-FROM :DEFINED + :KIND :GLOBAL-FUNCTION {1001D6DA43}>"[label="leaf"]; +"{6} REF [1814276436352168607]: +derived-type: #" -> "{8} REF [3898086476392545619]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{6} REF [1814276436352168607]: +derived-type: #" -> "{9} LVAR [4022411708127746323]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{8} REF [3898086476392545619]: +derived-type: #" -> "{A} CONSTANT [405874115581245099]: +value: FOO"[label="leaf"]; +"{8} REF [3898086476392545619]: +derived-type: #" -> "{B} NOT SUPPORTED YET: + # + :WHERE-FROM :DEFINED + :VARS (A B) {1001D90353}>) {1001D96AE3}>"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{8} REF [3898086476392545619]: +derived-type: #" -> "{C} LVAR [1186859114169146565]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{C} LVAR [1186859114169146565]: +%derived-type: # +dynamic-extent: NIL" -> "{D} COMBINATION [1475360876084922324]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{C} LVAR [1186859114169146565]: +%derived-type: # +dynamic-extent: NIL" -> "{8} REF [3898086476392545619]: +derived-type: #"[label="uses"]; +"{D} COMBINATION [1475360876084922324]: +kind: FULL +info: FULL" -> "{9} LVAR [4022411708127746323]: +%derived-type: # +dynamic-extent: NIL"[label="fun"]; +"{D} COMBINATION [1475360876084922324]: +kind: FULL +info: FULL" -> "{C} LVAR [1186859114169146565]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{D} COMBINATION [1475360876084922324]: +kind: FULL +info: FULL" -> "{E} LVAR [3728149842014737266]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{9} LVAR [4022411708127746323]: +%derived-type: # +dynamic-extent: NIL" -> "{D} COMBINATION [1475360876084922324]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{9} LVAR [4022411708127746323]: +%derived-type: # +dynamic-extent: NIL" -> "{6} REF [1814276436352168607]: +derived-type: #"[label="uses"]; +"{E} LVAR [3728149842014737266]: +%derived-type: # +dynamic-extent: NIL" -> "{D} COMBINATION [1475360876084922324]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{E} LVAR [3728149842014737266]: +%derived-type: # +dynamic-extent: NIL" -> "{F} REF [4127949218090209127]: +derived-type: #"[label="uses"]; +"{F} REF [4127949218090209127]: +derived-type: #" -> "{10} NOT SUPPORTED YET: + #"[label="leaf"]; +"{F} REF [4127949218090209127]: +derived-type: #" -> "{D} COMBINATION [1475360876084922324]: +kind: FULL +info: FULL"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{F} REF [4127949218090209127]: +derived-type: #" -> "{E} LVAR [3728149842014737266]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +} \ No newline at end of file diff -Nru sbcl-2.1.1/contrib/sb-graph/example/trace-3-DEFUNBAR.dot sbcl-2.1.11/contrib/sb-graph/example/trace-3-DEFUNBAR.dot --- sbcl-2.1.1/contrib/sb-graph/example/trace-3-DEFUNBAR.dot 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/example/trace-3-DEFUNBAR.dot 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,795 @@ +digraph { +"{0} COMPONENT [NIL]: ''DEFUN BAR''" -> "{1} CBLOCK [1575903357056582106]"[label="head"]; +"{0} COMPONENT [NIL]: ''DEFUN BAR''" -> "{2} CBLOCK [646725814620792949]"[label="tail"]; +"{1} CBLOCK [1575903357056582106]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{1} CBLOCK [1575903357056582106]" -> "{3} CBLOCK [463338187003706333]"[label="succ[# 0]"]; +"{1} CBLOCK [1575903357056582106]" -> "{4} CBLOCK [4485638051092447707]"[label="succ[# 1]"]; +"{3} CBLOCK [463338187003706333]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{3} CBLOCK [463338187003706333]" -> "{5} CBLOCK [4517821492800445034]"[label="succ[# 0]"]; +"{3} CBLOCK [463338187003706333]" -> "{4} CBLOCK [4485638051092447707]"[label="pred[# 0]"]; +"{3} CBLOCK [463338187003706333]" -> "{1} CBLOCK [1575903357056582106]"[label="pred[# 1]"]; +"{3} CBLOCK [463338187003706333]" -> "{6} BIND [2888465489035891844]"[label="start[ctran: BLOCK-START]"color="blue"]; +"{5} CBLOCK [4517821492800445034]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{5} CBLOCK [4517821492800445034]" -> "{7} CBLOCK [560949006574360106]"[label="succ[# 0]"]; +"{5} CBLOCK [4517821492800445034]" -> "{8} CBLOCK [4400914120625574157]"[label="succ[# 1]"]; +"{5} CBLOCK [4517821492800445034]" -> "{3} CBLOCK [463338187003706333]"[label="pred[# 0]"]; +"{5} CBLOCK [4517821492800445034]" -> "{9} ENTRY [3859794357893252955]: +"[label="start[ctran: BLOCK-START]"color="blue"]; +"{7} CBLOCK [560949006574360106]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{7} CBLOCK [560949006574360106]" -> "{2} CBLOCK [646725814620792949]"[label="succ[# 0]"]; +"{7} CBLOCK [560949006574360106]" -> "{5} CBLOCK [4517821492800445034]"[label="pred[# 0]"]; +"{7} CBLOCK [560949006574360106]" -> "{A} REF [970847179709888776]: +derived-type: #"[label="start[ctran: BLOCK-START]"color="blue"]; +"{2} CBLOCK [646725814620792949]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{2} CBLOCK [646725814620792949]" -> "{7} CBLOCK [560949006574360106]"[label="pred[# 0]"]; +"{2} CBLOCK [646725814620792949]" -> "{B} CBLOCK [3753698776976668030]"[label="pred[# 1]"]; +"{B} CBLOCK [3753698776976668030]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{B} CBLOCK [3753698776976668030]" -> "{2} CBLOCK [646725814620792949]"[label="succ[# 0]"]; +"{B} CBLOCK [3753698776976668030]" -> "{8} CBLOCK [4400914120625574157]"[label="pred[# 0]"]; +"{B} CBLOCK [3753698776976668030]" -> "{C} CRETURN [1875721060202815921]: +result-type: #"[label="start[ctran: BLOCK-START]"color="blue"]; +"{8} CBLOCK [4400914120625574157]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{8} CBLOCK [4400914120625574157]" -> "{B} CBLOCK [3753698776976668030]"[label="succ[# 0]"]; +"{8} CBLOCK [4400914120625574157]" -> "{5} CBLOCK [4517821492800445034]"[label="pred[# 0]"]; +"{8} CBLOCK [4400914120625574157]" -> "{D} REF [1142794053290553148]: +derived-type: #"[label="start[ctran: BLOCK-START]"color="blue"]; +"{D} REF [1142794053290553148]: +derived-type: #" -> "{E} CLAMBDA [1583379011298201103]: +%debug-name: (LET ((G5 G4))) +source-name: .ANONYMOUS. +kind: LET"[label="leaf"]; +"{D} REF [1142794053290553148]: +derived-type: #" -> "{F} REF [1091524514451138732]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{D} REF [1142794053290553148]: +derived-type: #" -> "{10} LVAR [1899977882035455531]: +%derived-type: NIL +dynamic-extent: NIL"[label="lvar"]; +"{E} CLAMBDA [1583379011298201103]: +%debug-name: (LET ((G5 G4))) +source-name: .ANONYMOUS. +kind: LET" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="home"]; +"{E} CLAMBDA [1583379011298201103]: +%debug-name: (LET ((G5 G4))) +source-name: .ANONYMOUS. +kind: LET" -> "{12} LAMBDA-VAR [2194186068469748088]: +arg-info: NIL +flags: 0"[label="vars[# 0]"]; +"{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="home"]; +"{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL" -> "{13} LAMBDA-VAR [551267047686253943]: +arg-info: NIL +flags: 0"[label="vars[# 0]"]; +"{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL" -> "{14} LAMBDA-VAR [1342701350530444948]: +arg-info: NIL +flags: 0"[label="vars[# 1]"]; +"{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL" -> "{15} LAMBDA-VAR [687676610963465975]: +arg-info: NIL +flags: 0"[label="vars[# 2]"]; +"{13} LAMBDA-VAR [551267047686253943]: +arg-info: NIL +flags: 0" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="home"]; +"{14} LAMBDA-VAR [1342701350530444948]: +arg-info: NIL +flags: 0" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="home"]; +"{15} LAMBDA-VAR [687676610963465975]: +arg-info: NIL +flags: 0" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="home"]; +"{12} LAMBDA-VAR [2194186068469748088]: +arg-info: NIL +flags: 0" -> "{E} CLAMBDA [1583379011298201103]: +%debug-name: (LET ((G5 G4))) +source-name: .ANONYMOUS. +kind: LET"[label="home"]; +"{F} REF [1091524514451138732]: +derived-type: #" -> "{16} LAMBDA-VAR [4210063433964233181]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{F} REF [1091524514451138732]: +derived-type: #" -> "{17} COMBINATION [2114537499351968799]: +kind: LOCAL +info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{F} REF [1091524514451138732]: +derived-type: #" -> "{18} LVAR [1279162088182557763]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{16} LAMBDA-VAR [4210063433964233181]: +arg-info: NIL +flags: 0" -> "{19} CLAMBDA [1745095324529044804]: +%debug-name: (LET ((G4 CONSTANT))) +source-name: .ANONYMOUS. +kind: LET"[label="home"]; +"{19} CLAMBDA [1745095324529044804]: +%debug-name: (LET ((G4 CONSTANT))) +source-name: .ANONYMOUS. +kind: LET" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="home"]; +"{19} CLAMBDA [1745095324529044804]: +%debug-name: (LET ((G4 CONSTANT))) +source-name: .ANONYMOUS. +kind: LET" -> "{16} LAMBDA-VAR [4210063433964233181]: +arg-info: NIL +flags: 0"[label="vars[# 0]"]; +"{17} COMBINATION [2114537499351968799]: +kind: LOCAL +info: LOCAL" -> "{10} LVAR [1899977882035455531]: +%derived-type: NIL +dynamic-extent: NIL"[label="fun"]; +"{17} COMBINATION [2114537499351968799]: +kind: LOCAL +info: LOCAL" -> "{18} LVAR [1279162088182557763]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{10} LVAR [1899977882035455531]: +%derived-type: NIL +dynamic-extent: NIL" -> "{17} COMBINATION [2114537499351968799]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{10} LVAR [1899977882035455531]: +%derived-type: NIL +dynamic-extent: NIL" -> "{D} REF [1142794053290553148]: +derived-type: #"[label="uses"]; +"{18} LVAR [1279162088182557763]: +%derived-type: # +dynamic-extent: NIL" -> "{17} COMBINATION [2114537499351968799]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{18} LVAR [1279162088182557763]: +%derived-type: # +dynamic-extent: NIL" -> "{F} REF [1091524514451138732]: +derived-type: #"[label="uses"]; +"{C} CRETURN [1875721060202815921]: +result-type: #" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="lambda"]; +"{C} CRETURN [1875721060202815921]: +result-type: #" -> "{1A} LVAR [934340460890599439]: +%derived-type: NIL +dynamic-extent: NIL"[label="result"]; +"{1A} LVAR [934340460890599439]: +%derived-type: NIL +dynamic-extent: NIL" -> "{C} CRETURN [1875721060202815921]: +result-type: #"[label="dest"color="brown"]; +"{1A} LVAR [934340460890599439]: +%derived-type: NIL +dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]: +kind: KNOWN +info: #"[label="uses"]; +"{1B} COMBINATION [875787350148863859]: +kind: KNOWN +info: #" -> "{1C} LVAR [880575187628074238]: +%derived-type: # +dynamic-extent: NIL"[label="fun"]; +"{1B} COMBINATION [875787350148863859]: +kind: KNOWN +info: #" -> "{1D} LVAR [2954358970637004122]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{1B} COMBINATION [875787350148863859]: +kind: KNOWN +info: #" -> "{1E} LVAR [1183996723568101089]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{1C} LVAR [880575187628074238]: +%derived-type: # +dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{1C} LVAR [880575187628074238]: +%derived-type: # +dynamic-extent: NIL" -> "{1F} REF [1077682984383576289]: +derived-type: #"[label="uses"]; +"{1F} REF [1077682984383576289]: +derived-type: #" -> "{20} NOT SUPPORTED YET: + # + :DEFINED-TYPE # + :WHERE-FROM :DECLARED + :KIND :GLOBAL-FUNCTION {1002A2E013}>"[label="leaf"]; +"{1F} REF [1077682984383576289]: +derived-type: #" -> "{21} REF [3270722447377338959]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{1F} REF [1077682984383576289]: +derived-type: #" -> "{1C} LVAR [880575187628074238]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{21} REF [3270722447377338959]: +derived-type: #" -> "{22} NOT SUPPORTED YET: + # + :DEFINED-TYPE # + :WHERE-FROM :DEFINED-HERE + :KIND :GLOBAL-FUNCTION {1002A2E323}>"[label="leaf"]; +"{21} REF [3270722447377338959]: +derived-type: #" -> "{23} REF [3193645899558233143]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{21} REF [3270722447377338959]: +derived-type: #" -> "{24} LVAR [1092023012539887227]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{23} REF [3193645899558233143]: +derived-type: #" -> "{13} LAMBDA-VAR [551267047686253943]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{23} REF [3193645899558233143]: +derived-type: #" -> "{25} REF [2658638157906711011]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{23} REF [3193645899558233143]: +derived-type: #" -> "{26} LVAR [1584308892107556128]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{25} REF [2658638157906711011]: +derived-type: #" -> "{14} LAMBDA-VAR [1342701350530444948]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{25} REF [2658638157906711011]: +derived-type: #" -> "{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{25} REF [2658638157906711011]: +derived-type: #" -> "{28} LVAR [2490411435938110265]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL" -> "{24} LVAR [1092023012539887227]: +%derived-type: # +dynamic-extent: NIL"[label="fun"]; +"{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL" -> "{26} LVAR [1584308892107556128]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL" -> "{28} LVAR [2490411435938110265]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{24} LVAR [1092023012539887227]: +%derived-type: # +dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{24} LVAR [1092023012539887227]: +%derived-type: # +dynamic-extent: NIL" -> "{21} REF [3270722447377338959]: +derived-type: #"[label="uses"]; +"{26} LVAR [1584308892107556128]: +%derived-type: # +dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{26} LVAR [1584308892107556128]: +%derived-type: # +dynamic-extent: NIL" -> "{23} REF [3193645899558233143]: +derived-type: #"[label="uses"]; +"{28} LVAR [2490411435938110265]: +%derived-type: # +dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{28} LVAR [2490411435938110265]: +%derived-type: # +dynamic-extent: NIL" -> "{25} REF [2658638157906711011]: +derived-type: #"[label="uses"]; +"{1D} LVAR [2954358970637004122]: +%derived-type: # +dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{1D} LVAR [2954358970637004122]: +%derived-type: # +dynamic-extent: NIL" -> "{29} NOT SUPPORTED YET: + # + :ASSERTED-TYPE # + :TYPE-TO-CHECK # {1002A31703}>"[label="uses"]; +"{1E} LVAR [1183996723568101089]: +%derived-type: # +dynamic-extent: NIL" -> "{1B} COMBINATION [875787350148863859]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{1E} LVAR [1183996723568101089]: +%derived-type: # +dynamic-extent: NIL" -> "{2A} REF [3033938375645121583]: +derived-type: #"[label="uses"]; +"{2A} REF [3033938375645121583]: +derived-type: #" -> "{15} LAMBDA-VAR [687676610963465975]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{2A} REF [3033938375645121583]: +derived-type: #" -> "{2B} REF [1791781268393324760]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{2A} REF [3033938375645121583]: +derived-type: #" -> "{1E} LVAR [1183996723568101089]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{2B} REF [1791781268393324760]: +derived-type: #" -> "{19} CLAMBDA [1745095324529044804]: +%debug-name: (LET ((G4 CONSTANT))) +source-name: .ANONYMOUS. +kind: LET"[label="leaf"]; +"{2B} REF [1791781268393324760]: +derived-type: #" -> "{2C} COMBINATION [1668396070861299820]: +kind: LOCAL +info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{2B} REF [1791781268393324760]: +derived-type: #" -> "{2D} LVAR [3615461272610505909]: +%derived-type: NIL +dynamic-extent: NIL"[label="lvar"]; +"{2C} COMBINATION [1668396070861299820]: +kind: LOCAL +info: LOCAL" -> "{2D} LVAR [3615461272610505909]: +%derived-type: NIL +dynamic-extent: NIL"[label="fun"]; +"{2C} COMBINATION [1668396070861299820]: +kind: LOCAL +info: LOCAL" -> "{2E} LVAR [1415646066275954498]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{2D} LVAR [3615461272610505909]: +%derived-type: NIL +dynamic-extent: NIL" -> "{2C} COMBINATION [1668396070861299820]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{2D} LVAR [3615461272610505909]: +%derived-type: NIL +dynamic-extent: NIL" -> "{2B} REF [1791781268393324760]: +derived-type: #"[label="uses"]; +"{2E} LVAR [1415646066275954498]: +%derived-type: # +dynamic-extent: NIL" -> "{2C} COMBINATION [1668396070861299820]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{2E} LVAR [1415646066275954498]: +%derived-type: # +dynamic-extent: NIL" -> "{27} COMBINATION [4361784411754163848]: +kind: FULL +info: FULL"[label="uses"]; +"{A} REF [970847179709888776]: +derived-type: #" -> "{2F} NOT SUPPORTED YET: + # + :DEFINED-TYPE # + :WHERE-FROM :DECLARED + :KIND :GLOBAL-FUNCTION {1002A37C83}>"[label="leaf"]; +"{A} REF [970847179709888776]: +derived-type: #" -> "{30} REF [2480652678179831556]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{A} REF [970847179709888776]: +derived-type: #" -> "{31} LVAR [4253175545486229054]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{30} REF [2480652678179831556]: +derived-type: #" -> "{16} LAMBDA-VAR [4210063433964233181]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{30} REF [2480652678179831556]: +derived-type: #" -> "{32} REF [4597392725968595806]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{30} REF [2480652678179831556]: +derived-type: #" -> "{33} LVAR [351302786686104344]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{32} REF [4597392725968595806]: +derived-type: #" -> "{34} CONSTANT [1034096512296901705]: +value: OBJECT-NOT-NUMBER-ERROR"[label="leaf"]; +"{32} REF [4597392725968595806]: +derived-type: #" -> "{35} REF [4291216069658349752]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{32} REF [4597392725968595806]: +derived-type: #" -> "{36} LVAR [742349938659844719]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{35} REF [4291216069658349752]: +derived-type: #" -> "{37} CONSTANT [3166890015804126914]: +value: NIL"[label="leaf"]; +"{35} REF [4291216069658349752]: +derived-type: #" -> "{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{35} REF [4291216069658349752]: +derived-type: #" -> "{39} LVAR [919264330689577080]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #" -> "{31} LVAR [4253175545486229054]: +%derived-type: # +dynamic-extent: NIL"[label="fun"]; +"{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #" -> "{33} LVAR [351302786686104344]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #" -> "{36} LVAR [742349938659844719]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #" -> "{39} LVAR [919264330689577080]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 2]"]; +"{31} LVAR [4253175545486229054]: +%derived-type: # +dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{31} LVAR [4253175545486229054]: +%derived-type: # +dynamic-extent: NIL" -> "{A} REF [970847179709888776]: +derived-type: #"[label="uses"]; +"{33} LVAR [351302786686104344]: +%derived-type: # +dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{33} LVAR [351302786686104344]: +%derived-type: # +dynamic-extent: NIL" -> "{30} REF [2480652678179831556]: +derived-type: #"[label="uses"]; +"{36} LVAR [742349938659844719]: +%derived-type: # +dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{36} LVAR [742349938659844719]: +%derived-type: # +dynamic-extent: NIL" -> "{32} REF [4597392725968595806]: +derived-type: #"[label="uses"]; +"{39} LVAR [919264330689577080]: +%derived-type: # +dynamic-extent: NIL" -> "{38} COMBINATION [3837710288170316803]: +kind: KNOWN +info: #"[label="dest"color="brown"]; +"{39} LVAR [919264330689577080]: +%derived-type: # +dynamic-extent: NIL" -> "{35} REF [4291216069658349752]: +derived-type: #"[label="uses"]; +"{9} ENTRY [3859794357893252955]: +" -> "{3A} NOT SUPPORTED YET: + # {1002A2DEF3}>"[label="cleanup"]; +"{9} ENTRY [3859794357893252955]: +" -> "{1F} REF [1077682984383576289]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{9} ENTRY [3859794357893252955]: +" -> "{9} ENTRY [3859794357893252955]: +"[label="prev[ctran: BLOCK-START]"color="blue"]; +"{4} CBLOCK [4485638051092447707]" -> "{0} COMPONENT [NIL]: ''DEFUN BAR''"[label="component"]; +"{4} CBLOCK [4485638051092447707]" -> "{3} CBLOCK [463338187003706333]"[label="succ[# 0]"]; +"{4} CBLOCK [4485638051092447707]" -> "{1} CBLOCK [1575903357056582106]"[label="pred[# 0]"]; +"{4} CBLOCK [4485638051092447707]" -> "{3B} BIND [1357533544267766393]"[label="start[ctran: BLOCK-START]"color="blue"]; +"{3B} BIND [1357533544267766393]" -> "{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="lambda"]; +"{3B} BIND [1357533544267766393]" -> "{3D} REF [1764939026324736725]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="green"]; +"{3B} BIND [1357533544267766393]" -> "{3B} BIND [1357533544267766393]"[label="prev[ctran: BLOCK-START]"color="red"]; +"{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{3E} LAMBDA-VAR [602304310100471643]: +arg-info: NIL +flags: 1"[label="vars[# 0]"]; +"{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{3F} LAMBDA-VAR [3684977715938429788]: +arg-info: NIL +flags: 0"[label="vars[# 1]"]; +"{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{40} LAMBDA-VAR [1054668136212602532]: +arg-info: NIL +flags: 0"[label="vars[# 2]"]; +"{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL" -> "{41} LAMBDA-VAR [4315196173549852881]: +arg-info: NIL +flags: 0"[label="vars[# 3]"]; +"{3E} LAMBDA-VAR [602304310100471643]: +arg-info: NIL +flags: 1" -> "{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{3F} LAMBDA-VAR [3684977715938429788]: +arg-info: NIL +flags: 0" -> "{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{40} LAMBDA-VAR [1054668136212602532]: +arg-info: NIL +flags: 0" -> "{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{41} LAMBDA-VAR [4315196173549852881]: +arg-info: NIL +flags: 0" -> "{3C} CLAMBDA [2613760754162345450]: +%debug-name: (XEP BAR) +source-name: .ANONYMOUS. +kind: EXTERNAL"[label="home"]; +"{3D} REF [1764939026324736725]: +derived-type: #" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="leaf"]; +"{3D} REF [1764939026324736725]: +derived-type: #" -> "{42} REF [842470847812081026]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{3D} REF [1764939026324736725]: +derived-type: #" -> "{43} LVAR [1888062279493340457]: +%derived-type: NIL +dynamic-extent: NIL"[label="lvar"]; +"{42} REF [842470847812081026]: +derived-type: #" -> "{3F} LAMBDA-VAR [3684977715938429788]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{42} REF [842470847812081026]: +derived-type: #" -> "{44} REF [2055375462078303612]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{42} REF [842470847812081026]: +derived-type: #" -> "{45} LVAR [4254170655862804359]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{44} REF [2055375462078303612]: +derived-type: #" -> "{40} LAMBDA-VAR [1054668136212602532]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{44} REF [2055375462078303612]: +derived-type: #" -> "{46} REF [4363891311576890011]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{44} REF [2055375462078303612]: +derived-type: #" -> "{47} LVAR [3883248025090896421]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{46} REF [4363891311576890011]: +derived-type: #" -> "{41} LAMBDA-VAR [4315196173549852881]: +arg-info: NIL +flags: 0"[label="leaf"]; +"{46} REF [4363891311576890011]: +derived-type: #" -> "{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{46} REF [4363891311576890011]: +derived-type: #" -> "{49} LVAR [571401066792478435]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL" -> "{43} LVAR [1888062279493340457]: +%derived-type: NIL +dynamic-extent: NIL"[label="fun"]; +"{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL" -> "{45} LVAR [4254170655862804359]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL" -> "{47} LVAR [3883248025090896421]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL" -> "{49} LVAR [571401066792478435]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 2]"]; +"{43} LVAR [1888062279493340457]: +%derived-type: NIL +dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{43} LVAR [1888062279493340457]: +%derived-type: NIL +dynamic-extent: NIL" -> "{3D} REF [1764939026324736725]: +derived-type: #"[label="uses"]; +"{45} LVAR [4254170655862804359]: +%derived-type: # +dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{45} LVAR [4254170655862804359]: +%derived-type: # +dynamic-extent: NIL" -> "{42} REF [842470847812081026]: +derived-type: #"[label="uses"]; +"{47} LVAR [3883248025090896421]: +%derived-type: # +dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{47} LVAR [3883248025090896421]: +%derived-type: # +dynamic-extent: NIL" -> "{44} REF [2055375462078303612]: +derived-type: #"[label="uses"]; +"{49} LVAR [571401066792478435]: +%derived-type: # +dynamic-extent: NIL" -> "{48} COMBINATION [3442268956323344380]: +kind: LOCAL +info: LOCAL"[label="dest"color="brown"]; +"{49} LVAR [571401066792478435]: +%derived-type: # +dynamic-extent: NIL" -> "{46} REF [4363891311576890011]: +derived-type: #"[label="uses"]; +"{6} BIND [2888465489035891844]" -> "{11} CLAMBDA [274430610392932488]: +%debug-name: NIL +source-name: BAR +kind: NIL"[label="lambda"]; +"{6} BIND [2888465489035891844]" -> "{6} BIND [2888465489035891844]"[label="prev[ctran: BLOCK-START]"color="red"]; +} \ No newline at end of file diff -Nru sbcl-2.1.1/contrib/sb-graph/example/trace-4-toplevelform.dot sbcl-2.1.11/contrib/sb-graph/example/trace-4-toplevelform.dot --- sbcl-2.1.1/contrib/sb-graph/example/trace-4-toplevelform.dot 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/example/trace-4-toplevelform.dot 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,128 @@ +digraph { +"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{1} CBLOCK [4546777747233824097]"[label="head"]; +"{0} COMPONENT [TOPLEVEL]: ''top level form''" -> "{2} CBLOCK [293033905737092273]"[label="tail"]; +"{1} CBLOCK [4546777747233824097]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"]; +"{1} CBLOCK [4546777747233824097]" -> "{3} CBLOCK [2374185086335330572]"[label="succ[# 0]"]; +"{3} CBLOCK [2374185086335330572]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"]; +"{3} CBLOCK [2374185086335330572]" -> "{2} CBLOCK [293033905737092273]"[label="succ[# 0]"]; +"{3} CBLOCK [2374185086335330572]" -> "{1} CBLOCK [4546777747233824097]"[label="pred[# 0]"]; +"{3} CBLOCK [2374185086335330572]" -> "{4} BIND [2124840765505938481]"[label="start[ctran: BLOCK-START]"color="blue"]; +"{2} CBLOCK [293033905737092273]" -> "{0} COMPONENT [TOPLEVEL]: ''top level form''"[label="component"]; +"{2} CBLOCK [293033905737092273]" -> "{3} CBLOCK [2374185086335330572]"[label="pred[# 0]"]; +"{4} BIND [2124840765505938481]" -> "{5} CLAMBDA [3240387953118118454]: +%debug-name: (TOP-LEVEL-FORM + (%DEFUN 'BAR + (NAMED-LAMBDA BAR + (B C D) + (DECLARE (TOP-LEVEL-FORM)) + (BLOCK BAR (* # D))))) +source-name: .ANONYMOUS. +kind: TOPLEVEL"[label="lambda"]; +"{4} BIND [2124840765505938481]" -> "{6} REF [1909866941284971615]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="green"]; +"{4} BIND [2124840765505938481]" -> "{4} BIND [2124840765505938481]"[label="prev[ctran: BLOCK-START]"color="red"]; +"{5} CLAMBDA [3240387953118118454]: +%debug-name: (TOP-LEVEL-FORM + (%DEFUN 'BAR + (NAMED-LAMBDA BAR + (B C D) + (DECLARE (TOP-LEVEL-FORM)) + (BLOCK BAR (* # D))))) +source-name: .ANONYMOUS. +kind: TOPLEVEL" -> "{5} CLAMBDA [3240387953118118454]: +%debug-name: (TOP-LEVEL-FORM + (%DEFUN 'BAR + (NAMED-LAMBDA BAR + (B C D) + (DECLARE (TOP-LEVEL-FORM)) + (BLOCK BAR (* # D))))) +source-name: .ANONYMOUS. +kind: TOPLEVEL"[label="home"]; +"{6} REF [1909866941284971615]: +derived-type: #" -> "{7} NOT SUPPORTED YET: + # + :DEFINED-TYPE # + :WHERE-FROM :DEFINED + :KIND :GLOBAL-FUNCTION {1001D6DA43}>"[label="leaf"]; +"{6} REF [1909866941284971615]: +derived-type: #" -> "{8} REF [784168789779171862]: +derived-type: #"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{6} REF [1909866941284971615]: +derived-type: #" -> "{9} LVAR [2701418418247132151]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{8} REF [784168789779171862]: +derived-type: #" -> "{A} CONSTANT [1255380336112371100]: +value: BAR"[label="leaf"]; +"{8} REF [784168789779171862]: +derived-type: #" -> "{B} NOT SUPPORTED YET: + # + :WHERE-FROM :DEFINED + :VARS (B C D) {1002A2D803}>) {1002A2ED73}>"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{8} REF [784168789779171862]: +derived-type: #" -> "{C} LVAR [2400416095386229337]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +"{C} LVAR [2400416095386229337]: +%derived-type: # +dynamic-extent: NIL" -> "{D} COMBINATION [2858390395914678261]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{C} LVAR [2400416095386229337]: +%derived-type: # +dynamic-extent: NIL" -> "{8} REF [784168789779171862]: +derived-type: #"[label="uses"]; +"{D} COMBINATION [2858390395914678261]: +kind: FULL +info: FULL" -> "{9} LVAR [2701418418247132151]: +%derived-type: # +dynamic-extent: NIL"[label="fun"]; +"{D} COMBINATION [2858390395914678261]: +kind: FULL +info: FULL" -> "{C} LVAR [2400416095386229337]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 0]"]; +"{D} COMBINATION [2858390395914678261]: +kind: FULL +info: FULL" -> "{E} LVAR [2458505184304471429]: +%derived-type: # +dynamic-extent: NIL"[label="args[# 1]"]; +"{9} LVAR [2701418418247132151]: +%derived-type: # +dynamic-extent: NIL" -> "{D} COMBINATION [2858390395914678261]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{9} LVAR [2701418418247132151]: +%derived-type: # +dynamic-extent: NIL" -> "{6} REF [1909866941284971615]: +derived-type: #"[label="uses"]; +"{E} LVAR [2458505184304471429]: +%derived-type: # +dynamic-extent: NIL" -> "{D} COMBINATION [2858390395914678261]: +kind: FULL +info: FULL"[label="dest"color="brown"]; +"{E} LVAR [2458505184304471429]: +%derived-type: # +dynamic-extent: NIL" -> "{F} REF [4329924708167232172]: +derived-type: #"[label="uses"]; +"{F} REF [4329924708167232172]: +derived-type: #" -> "{10} NOT SUPPORTED YET: + #"[label="leaf"]; +"{F} REF [4329924708167232172]: +derived-type: #" -> "{D} COMBINATION [2858390395914678261]: +kind: FULL +info: FULL"[label="next[ctran: INSIDE-BLOCK]"color="blue"]; +"{F} REF [4329924708167232172]: +derived-type: #" -> "{E} LVAR [2458505184304471429]: +%derived-type: # +dynamic-extent: NIL"[label="lvar"]; +} \ No newline at end of file diff -Nru sbcl-2.1.1/contrib/sb-graph/Makefile sbcl-2.1.11/contrib/sb-graph/Makefile --- sbcl-2.1.1/contrib/sb-graph/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/Makefile 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,2 @@ +SYSTEM=sb-graph +include ../asdf-module.mk diff -Nru sbcl-2.1.1/contrib/sb-graph/readme.org sbcl-2.1.11/contrib/sb-graph/readme.org --- sbcl-2.1.1/contrib/sb-graph/readme.org 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/readme.org 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,124 @@ +* ir1-grapher + This library graphs SBCL [[https://cmucl.org/docs/internals/html/The-Implicit-Continuation-Representation.html#The-Implicit-Continuation-Representation][ir1]] and outputs graphviz. + + As of now, it is stil unfinished. There are a few tweaks that are + needed to improve useablility, in particular, I think the rendering + could be done a lot better, with subgraphs, to make it a lot more + readable. Also to make it more readable, I'm planning on + implementing rainbow-parens-esque arrow + label color randomization. + +** How do I use it during compiler tracing? + To load the system, you can call ~(asdf:load-system + :ir1-grapher)~ once you have either loaded ~ir1-grapher.asd~ + manually, or placed the folder inside your [[https://common-lisp.net/project/asdf/asdf/Configuring-ASDF-to-find-your-systems.html][ASDF load path]]. + + Because of the way it hooks in the compiler, you shouldn't actually + have to do anything after loading it except turning on trace output + of the compiler (SBCL), and adding ~:sb-graph~ to + ~sb-c::*compile-trace-targets*~. Turning on the tracing can be done + by calling ~(compile-file "file" :trace-file t)~, and adding + ~:sb-graph~ to ~sb-c::*compile-trace-targets*~ can be done however + you want. After compilation is done, alongside the normal trace + file, SBCL is hooked into writing a series of .dot files, which + contain the graphviz DOT representation of all the components + compiled. If you set ~*compile-progress*~ to ~T~, it will print out + progress information, and will tell you when and where it writes + out the graphviz files. + +** How do I use the system interactively? + If you ran into a compiler error, and want to graph the + still-in-memory code interactively, you can do so with the + following functions: + +*** ~(make-and-dfs object distance)~ + This function takes an ir1 object ~object~, and integer + ~distance~, and returns a graph object with every node up to + ~distance~ hops away from ~object~ in its ~dfs-table~. Each object + is tagged with a "codename", visible as a hex digit in braces at + the start of each graph node. + + Then, to operate on the graph interactively, you can use: + +*** ~(interactively-graph graph &optional filename)~ + This function takes a ~graph~ and a ~filename~, and sets the + current working graph to it, and the current output file to the + filename. When calling ~output~ and ~expand~, the graph will be + written to ~filename~. + +*** ~(output)~ + This function outputs the current working graph to a string, and + if ~interactively-graph~ was called with a filename, writes it to + that file. + +*** ~(expand codename)~ + After you've rendered the graph, if you want to add a node to the + ~dfs-table~ (thus expanding the amount of the in-memory objects + rendered), call this function with the codename of the new object + you'd like to add. Example: ~(expand "A")~. + + If you passed a filename to ~interactively-graph~, this function + will then write the render to file automatically. + +*** ~(unexpand codename)~ + Removes the node tied to the codename from the table, meaning that + it won't get its neighbours traversed when graph rendering is done. + +*** ~(get-node codename)~ + Returns the object tied to ~codename~ from the current interactive + graph. + +** And if you don't want to use ~interactively-graph~: +*** ~(render-graph graph)~ + Given a graph with objects in its ~dfs-table~, returns a string of + the rendering of the graph in DOT. + + Does the same thing as ~output~, but without using + ~interactively-graph~. + +*** ~(expand-codename graph codename)~ + Given a graph and codename, put the node tied to ~codename~ into + the ~dfs-table~ of the graph. + + Does the same thing as ~expand~, but without using + ~interactively-graph~. + +*** ~(unexpand-codename graph codename)~ + Does the same thing as ~unexpand~, but without using + ~interactively-graph~. + +*** ~(get-node-from-codename graph codename)~ + Return the node tied to ~codename~ in ~graph~. + + Does the same thing as ~node~, but without using + ~interactively-graph~. + +** What good is ~interactively-graph~ if I need to run ~dot~ every time the graph gets output? + That's where ~render-on-change.sh~ comes in. Run + ~render-on-change.sh~ with two arguments. First is the input DOT + file, and second is the output SVG file. If you want to export to a + different format, just modify the ~-Tsvg~ of the script. + +** Help! It's saying there's a package locking error. + Run ~(sb-ext:unlock-package :sb-c)~ in the REPL, or compile SBCL + with ~--with-sb-devel~ (if you're doing compiler work, you should + probably do this anyways). In ~src/package.lisp~, there's a + ~(sb-ext:unlock-package :sb-c)~ statement, but it seems to not work + as expected. + +** But what if the compiler breaks your library, or I want to muck around with it? + ~hooking.lisp~ contains all the code that is used to hook the + compiler directly, and ~graphing.lisp~ goes from the compiler data + structures to the graphviz DOT format. + + Right now, I'm assuming that the only place that the compiler will + ever call ~sb-c::ir2-convert~ for each component is inside + ~%compile-component~, and only one time. If this becomes no longer + true, then the hooking location/manner will have to be modified. + +** After the ~.dot~ files get output, how do I render them? + ~dot -T input.dot > output~. + For example, ~dot -Tsvg trace-1-DEFUNFOO.dot > out.svg~. + +** Can I see an example? + Yes, look at the ~example/~ folder. It contains the dot output + when running ~(compile-file "testfile" :trace-file t)~. diff -Nru sbcl-2.1.1/contrib/sb-graph/render-on-change.sh sbcl-2.1.11/contrib/sb-graph/render-on-change.sh --- sbcl-2.1.1/contrib/sb-graph/render-on-change.sh 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/render-on-change.sh 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,8 @@ +#!/bin/bash + +inotifywait -e close_write,moved_to,create -m . | +while read -r directory events filename; do + if [ "$filename" = "$1" ]; then + dot -Tsvg $1 > $2 + fi +done diff -Nru sbcl-2.1.1/contrib/sb-graph/sb-graph.asd sbcl-2.1.11/contrib/sb-graph/sb-graph.asd --- sbcl-2.1.1/contrib/sb-graph/sb-graph.asd 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/sb-graph.asd 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,17 @@ +;;; -*- Lisp -*- +#-(or sb-testing-contrib sb-building-contrib) +(error "Can't build contribs with ASDF") + +(asdf:defsystem "sb-graph" + :serial t + :components + ((:module src + :serial t + :components + ((:file "package") + (:file "graphing") + (:file "hooking")))) + :perform (load-op :after (o c) (provide 'sb-graph))) + +;;; The tests for sb-graph are under tests/sb-graph.impure.lisp to +;;; take advantage of the sbcl regression tester features. diff -Nru sbcl-2.1.1/contrib/sb-graph/sb-graph.texinfo sbcl-2.1.11/contrib/sb-graph/sb-graph.texinfo --- sbcl-2.1.1/contrib/sb-graph/sb-graph.texinfo 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/sb-graph.texinfo 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,120 @@ +@node ICR Graphing +@comment node-name, next, previous, up +@chapter ICR Graphing +@cindex Graph, ICR, IR1 + +The @code{sb-graph} module provides a graphing tool for SBCL ir1. It +outputs graphviz DOT format. + +Its main features are that it can hook compilation so that SBCL can +output .dot files when compiler tracing is enabled, and, given a graph +in memory, provide the facility to interactively graph and interact with +it. + +@menu +* Overview:: +* User Manual:: +* API Description:: +@end menu + +@node Overview +@section Overview + +@node User Manual +@section User Manual + +If all you want to do is output .dot files during compiler tracing, you +shouldn’t actually have to do anything after loading it except turning +on SBCL’s trace output. This can be done by calling (compile-file "file" +:trace-file t). After compilation is done, alongside the normal trace +file, SBCL is transparently hooked into writing a series of .dot files, +which contain the graphviz DOT representation of all the components +compiled. If you set sb-c::*compile-progress* to T, it will print out +progress information, and will tell you when and where it writes out the +graphviz files. + +To use it interactively, call interactively-graph with a graph object +and output filename. After this is done, output, expand, and get-node +can be used to interact with said graph. As you call expand, the graph +will be output to the filename you specified. In the root of the +repository is a shell script render-on-change.sh which can be run with +two arguments: the input DOT file (the one passed to +interactively-graph), as well as an output SVG file that graphviz will +render to every time the file is changed on disk. This uses +inotify-wait, and so inotify-utils must be installed. As far as I know +this only works on Linux. A similar thing could be written for other +operating systems, though. All-in-all, this allows for a very short +expand-render-display loop. + +@node API Description +@section API Description + +@itemize + +@item + +* (make-and-dfs object distance) + +This function takes an ir1 object object, and integer distance, and +returns a graph object with every node up to distance hops away from +object in its dfs-table. Each object is tagged with a “codename”, +visible as a hex digit in braces at the start of each graph node. + +@item + +* (interactively-graph graph &optional filename) + +This function takes a graph and a filename, and sets the current working +graph to it, and the current output file to the filename. When calling +output and expand, the graph will be written to filename. + +@item + +* (output) + +This function outputs the current working graph to a string, and if +interactively-graph was called with a filename, writes it to that file. + +@item + +* (expand codename) + +After you’ve rendered the graph, if you want to add +a node to the dfs-table (thus expanding the amount of the in-memory +objects rendered), call this function with the codename of the new +object you’d like to add. Example: (expand "A"). + +If you passed a filename to interactively-graph, this function will then +write the render to file automatically. + +@item + +* (get-node codename) + +Returns the object tied to codename from the current interactive graph. + +@item + +* (render-graph graph) + +Given a graph with objects in its dfs-table, returns a string of the +rendering of the graph in DOT. + +Does the same thing as output, but without using interactively-graph. + +@item + +* (expand-graph-codename graph codename) + +Given a graph and codename, put the node tied to codename into the +dfs-table of the graph. + +Does the same thing as expand, but without using interactively-graph. + +@item + +* (get-node-from-codename graph codename) + +Return the node tied to codename in graph. + +Does the same thing as node, but without using interactively-graph. diff -Nru sbcl-2.1.1/contrib/sb-graph/src/graphing.lisp sbcl-2.1.11/contrib/sb-graph/src/graphing.lisp --- sbcl-2.1.1/contrib/sb-graph/src/graphing.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/src/graphing.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,389 @@ +(in-package :sb-graph) + +(defun make-graph () + (make-instance 'graph + :stream (make-string-output-stream) + :dfs-table (make-hash-table :test 'eq :size 63) + :obj-table (make-hash-table :test 'eq :size 63) + :codename-table (make-hash-table :test 'equal :size 63) + :codename-number 0)) + +(defun make-and-dfs (object distance) + (let ((graph (make-graph))) + (dfs-add graph distance object) + graph)) + +(defun save-graph (str filename) + (with-open-file (s filename :direction :output :if-does-not-exist :create :if-exists :supersede) + (write-string str s))) + +;; dfs-table: obj -> T +;; obj-table: obj -> codename +;; codename-table: codename -> obj +(defclass graph () + ((stream :initarg :stream :accessor stream) + (dfs-table :initarg :dfs-table :reader dfs-table) + (obj-table :initarg :obj-table :reader obj-table) + (codename-table :initarg :codename-table :reader codename-table) + (codename-number :initarg :codename-number :accessor codename-number))) + +(defmethod render-graph (graph) + (get-output-stream-string (stream graph)) + (write-string (format nil "digraph {~%") (stream graph)) + (maphash #'(lambda (k v) (declare (ignore v)) (edges graph k)) (dfs-table graph)) + (write-string "}" (stream graph)) + (get-output-stream-string (stream graph))) + +;; RENDER-GRAPH goes through all the nodes in DFS-TABLE, so we add the +;; node corresponding to the given codename to the graph's DFS-TABLE +(defmethod expand-codename (graph codename) + (setf (gethash (gethash codename (codename-table graph)) + (dfs-table graph)) + t)) + +(defmethod unexpand-codename (graph codename) + (remhash (gethash codename (codename-table graph)) + (dfs-table graph))) + +(defun get-node-from-codename (graph codename) + (gethash codename (codename-table graph))) + +;; creates a new codename, ties it to this object, then returns it. +(defun add-to-code-tables (graph object) + (if (nth-value 1 (gethash object (obj-table graph))) + (gethash object (obj-table graph)) + (let ((new-codename (let ((res (format nil "~X" (codename-number graph)))) + (incf (codename-number graph)) + res))) + (setf (gethash object (obj-table graph)) + new-codename + (gethash new-codename (codename-table graph)) + object) + new-codename))) + +(let ((curr-graph nil) + (curr-file nil)) + (defun interactively-graph (graph &optional (filename nil)) + (setf curr-graph graph) + (setf curr-file filename)) + + (defun output () + (if curr-file + (save-graph (render-graph curr-graph) curr-file) + (render-graph curr-graph))) + + (defun expand (codename) + (expand-codename curr-graph codename) + (when curr-file + (output))) + + (defun unexpand (codename) + (unexpand-codename curr-graph codename) + (when curr-file + (output))) + + (defun get-node (codename) + (get-node-from-codename curr-graph codename))) + + +;; modify-str-plist returns a new plist which is identical except the +;; value associated with KEY has been replaced by what is returned by +;; funcalling func on the value +(defun modify-str-plist (plist key func) + (assert (= 0 (mod (length plist) 2))) + (apply #'nconc + (loop with ck = nil + with cv = nil + while (setf ck (car plist) + cv (cadr plist)) + collect (let ((v (if (string= key ck) + (list ck (funcall func cv)) + (list ck cv)))) + (setf plist (cddr plist)) + v)))) + +;; this is because graphviz doesn't allow nodes to have more than 16k +;; of text in them +(defun clamp (str) + (if (< 16300 (length str)) + (subseq str 0 16300) + str)) + +;; This was copied from the common lisp cookbook. +(defun replace-all (string part replacement &key (test #'char=)) + "Returns a new string in which all the occurences of the part +is replaced with replacement." + (with-output-to-string (out) + (loop with part-length = (length part) + for old-pos = 0 then (+ pos part-length) + for pos = (search part string + :start2 old-pos + :test test) + do (write-string string out + :start old-pos + :end (or pos (length string))) + when pos do (write-string replacement out) + while pos))) + +(defmethod edge ((graph graph) from to &rest options) + (assert (= 0 (mod (length options) 2))) + (format (stream graph) "\"{~A} ~A\" -> \"{~A} ~A\"[~A];~%" + (if (gethash from (obj-table graph)) + (gethash from (obj-table graph)) + (add-to-code-tables graph from)) + (replace-all (replace-all (clamp (display from)) "\"" "'") "\\" "\\\\") + (if (gethash to (obj-table graph)) + (gethash to (obj-table graph)) + (add-to-code-tables graph to)) + (replace-all (replace-all (clamp (display to)) "\"" "'") "\\" "\\\\") + (apply #'concatenate + (cons 'string + (loop with ck = nil + with cv = nil + while (setf ck (car options) + cv (cadr options)) + collect (let ((v (format nil "~A=\"~A\"" ck cv))) + (setf options (cddr options)) + v)))))) + +;; this is overriding the edge so that we can not render CTRANs +(defmethod edge ((graph graph) from (to sb-c::ctran) &rest options) + (apply #'edge (nconc (list graph from (sb-c::ctran-next to)) + (modify-str-plist options "label" + (lambda (x) + (concatenate 'string x (format nil "[ctran: ~A]" (sb-c::ctran-kind to))))) + (unless (find-if (lambda (x) (string= x "color")) options) + '("color" "blue"))))) + + +(defmethod edge ((graph graph) from (to list) &rest options) + (let ((counter 0)) + (mapc #'(lambda (x) + (apply #'edge + (nconc (list graph from x) + (modify-str-plist + options "label" + #'(lambda (x) + (let ((res (format nil "~A[# ~A]" + x counter))) + (incf counter) + res)))))) + to))) + +;; display goes from an object to the string representation that'll be +;; inside the graph nodes + +(defmethod display ((c sb-c::component)) + (format nil "COMPONENT: '~S'" + (sb-c::component-name c))) + +;; The sxhash is required to not end up with a single CBLOCK node +(defmethod display ((b sb-c::cblock)) + (format nil "CBLOCK")) + +(defmethod display ((ctran sb-c::ctran)) + (error "Trying to display a CTRAN, this shouldn't happen")) + +(defmethod display ((cl sb-c::clambda)) + (format nil "CLAMBDA:~%%debug-name: ~A~%source-name: ~A~%kind: ~A" + (sb-c::lambda-%debug-name cl) + (sb-c::lambda-%source-name cl) + (sb-c::lambda-kind cl))) + +(defmethod display ((cr sb-c::creturn)) + (format nil "CRETURN:~%result-type: ~A" + (sb-c::return-result-type cr))) + +(defmethod display ((bind sb-c::bind)) + (format nil "BIND")) + +(defmethod display ((ref sb-c::ref)) + (format nil "REF:~%derived-type: ~A" + (sb-c::ref-derived-type ref))) + +(defmethod display ((comb sb-c::combination)) + (format nil "COMBINATION:~%kind: ~A~%info: ~A" + (sb-c::combination-kind comb) + (sb-c::combination-info comb))) + +(defmethod display ((lvar sb-c::lvar)) + (format nil "LVAR:~%%derived-type: ~A~%dynamic-extent: ~A" + (sb-c::lvar-%derived-type lvar) + (sb-c::lvar-dynamic-extent lvar))) + +(defmethod display ((const sb-c::constant)) + (format nil "CONSTANT:~%value: ~A" + (sb-c::constant-value const))) + +(defmethod display ((lamvar sb-c::lambda-var)) + (format nil "LAMBDA-VAR:~%arg-info: ~A~%flags: ~A" + (sb-c::lambda-var-arg-info lamvar) + (sb-c::lambda-var-flags lamvar))) + +(defmethod display ((entry sb-c::entry)) + (format nil "ENTRY")) + +(defmethod display (obj) + (format nil "NOT SUPPORTED YET:~% ~A" obj)) + + +(defmethod edges ((graph graph) (objects list)) + (mapc #'(lambda (o) (edges graph o)) objects)) + +(defmethod edges ((graph graph) (component sb-c::component)) + (edge graph component (sb-c::component-head component) "label" "head") + (edge graph component (sb-c::component-tail component) "label" "tail")) + +(defmethod edges ((graph graph) (cblock sb-c::cblock)) + (edge graph cblock (sb-c::block-component cblock) "label" "component") + (edge graph cblock (sb-c::block-succ cblock) "label" "succ") + (edge graph cblock (sb-c::block-pred cblock) "label" "pred") + (edge graph cblock (sb-c::block-start cblock) "label" "start")) + +;; Unfinished +(defmethod edges ((graph graph) (cl sb-c::clambda)) + (edge graph cl (sb-c::lambda-home cl) "label" "home") + (edge graph cl (sb-c::lambda-vars cl) "label" "vars")) + +(defmethod edges ((graph graph) (cr sb-c::creturn)) + (edge graph cr (sb-c::return-lambda cr) "label" "lambda") + (edge graph cr (sb-c::return-result cr) "label" "result")) + +;; this is just a dummy function to skip the CTRAN +(defmethod edges ((graph graph) (ct sb-c::ctran))) + +(defmethod edges ((graph graph) (ref sb-c::ref)) + (edge graph ref (sb-c::ref-leaf ref) "label" "leaf") + (edge graph ref (sb-c::ref-next ref) "label" "next") + (edge graph ref (sb-c::ref-lvar ref) "label" "lvar")) + +(defmethod edges ((graph graph) (bind sb-c::bind)) + (edge graph bind (sb-c::bind-lambda bind) "label" "lambda") + (edge graph bind (sb-c::bind-next bind) "label" "next" "color" "green") + (edge graph bind (sb-c::bind-prev bind) "label" "prev" "color" "red")) + +(defmethod edges ((graph graph) (comb sb-c::combination)) + (edge graph comb (sb-c::combination-fun comb) "label" "fun") + (edge graph comb (sb-c::combination-args comb) "label" "args")) + +(defmethod edges ((graph graph) (lvar sb-c::lvar)) + (edge graph lvar (sb-c::lvar-dest lvar) "label" "dest" "color" "brown") + (edge graph lvar (sb-c::lvar-uses lvar) "label" "uses")) + +(defmethod edges ((graph graph) (lamvar sb-c::lambda-var)) + (edge graph lamvar (sb-c::lambda-var-home lamvar) "label" "home") + (edge graph lamvar (sb-c::lambda-var-sets lamvar) "label" "sets")) + +(defmethod edges ((graph graph) (entry sb-c::entry)) + (edge graph entry (sb-c::entry-exits entry) "label" "exits") + (edge graph entry (sb-c::entry-cleanup entry) "label" "cleanup") + (edge graph entry (sb-c::entry-next entry) "label" "next") + (edge graph entry (sb-c::entry-prev entry) "label" "prev")) + +(defmethod edges ((graph graph) object)) + +;; the name is a "pun" of the words 'unique' and 'graph' +(defmacro unig ((graph obj) &body body) + (let ((g (gensym)) + (o (gensym))) + `(let ((,g ,graph) + (,o ,obj)) + (unless (nth-value 1 (gethash ,o (dfs-table ,g))) + (setf (gethash ,o (dfs-table ,g)) t) + ,@body)))) + +(defmethod dfs-add ((graph graph) (distance integer) (objects list)) + (mapc #'(lambda (o) (dfs-add graph distance o)) objects)) + +;; a component should be rendered as a subgraph +(defmethod dfs-add ((graph graph) (distance integer) (component sb-c::component)) + (when (> distance 0) + (decf distance) + (unig (graph component) + (dfs-add graph distance (sb-c::component-head component)) + (dfs-add graph distance (sb-c::component-tail component))))) + +(defmethod dfs-add ((graph graph) (distance integer) (cblock sb-c::cblock)) + (when (> distance 0) + (decf distance) + (unig (graph cblock) + (dfs-add graph distance (sb-c::block-component cblock)) + (dfs-add graph distance (sb-c::block-succ cblock)) + (dfs-add graph distance (sb-c::block-pred cblock)) + (dfs-add graph distance (sb-c::block-start cblock))))) + +;; Unfinished +(defmethod dfs-add ((graph graph) (distance integer) (cl sb-c::clambda)) + (when (> distance 0) + (decf distance) + (unig (graph cl) + (dfs-add graph distance (sb-c::lambda-home cl)) + (dfs-add graph distance (sb-c::lambda-vars cl))))) + +(defmethod dfs-add ((graph graph) (distance integer) (cr sb-c::creturn)) + (when (> distance 0) + (decf distance) + (unig (graph cr) + (dfs-add graph distance (sb-c::return-lambda cr)) + (dfs-add graph distance (sb-c::return-result cr))))) + +;; (defmethod dfs-add ((graph graph) (distance integer) (node sb-c::node)) +;; ) + +;; this is just a dummy function to skip the CTRAN. Note that it +;; doesn't decf distance. +(defmethod dfs-add ((graph graph) (distance integer) (ct sb-c::ctran)) + (when (> distance 0) + (unig (graph ct) + (dfs-add graph distance (sb-c::ctran-next ct))))) + +(defmethod dfs-add ((graph graph) (distance integer) (ref sb-c::ref)) + (when (> distance 0) + (decf distance) + (unig (graph ref) + (dfs-add graph distance (sb-c::ref-leaf ref)) + (dfs-add graph distance (sb-c::ref-next ref)) + (dfs-add graph distance (sb-c::ref-lvar ref))))) + +(defmethod dfs-add ((graph graph) (distance integer) (bind sb-c::bind)) + (when (> distance 0) + (decf distance) + (unig (graph bind) + (dfs-add graph distance (sb-c::bind-lambda bind)) + (dfs-add graph distance (sb-c::bind-next bind)) + (dfs-add graph distance (sb-c::bind-prev bind))))) + +(defmethod dfs-add ((graph graph) (distance integer) (comb sb-c::combination)) + (when (> distance 0) + (decf distance) + (unig (graph comb) + (dfs-add graph distance (sb-c::combination-fun comb)) + (dfs-add graph distance (sb-c::combination-args comb))))) + +(defmethod dfs-add ((graph graph) (distance integer) (lvar sb-c::lvar)) + (when (> distance 0) + (decf distance) + (unig (graph lvar) + (dfs-add graph distance (sb-c::lvar-dest lvar)) + (dfs-add graph distance (sb-c::lvar-uses lvar))))) + +(defmethod dfs-add ((graph graph) (distance integer) (lamvar sb-c::lambda-var)) + (when (> distance 0) + (decf distance) + (unig (graph lamvar) + (dfs-add graph distance (sb-c::lambda-var-home lamvar)) + (dfs-add graph distance (sb-c::lambda-var-sets lamvar))))) + +(defmethod dfs-add ((graph graph) (distance integer) (entry sb-c::entry)) + (when (> distance 0) + (decf distance) + (unig (graph entry) + (dfs-add graph distance (sb-c::entry-exits entry)) + (dfs-add graph distance (sb-c::entry-cleanup entry)) + (dfs-add graph distance (sb-c::entry-next entry)) + (dfs-add graph distance (sb-c::entry-prev entry))))) + +(defmethod dfs-add ((graph graph) (distance integer) object) + (when (> distance 0) + (decf distance) + (unig (graph object)))) diff -Nru sbcl-2.1.1/contrib/sb-graph/src/hooking.lisp sbcl-2.1.11/contrib/sb-graph/src/hooking.lisp --- sbcl-2.1.1/contrib/sb-graph/src/hooking.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/src/hooking.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,87 @@ +(in-package :sb-graph) + +(eval-when (:compile-toplevel :load-toplevel) + (defvar *hook-enabled* (make-hash-table))) + +(defmacro hook (fun lambda-list &body body) + (let ((ll (gensym)) + (f (gensym)) + (orig (gensym))) + `(let ((,f ',fun)) + (when (nth-value 1 (gethash ',f *hook-enabled*)) + (unhook ,fun)) + (setf (gethash ,f *hook-enabled*) t) + (sb-int::encapsulate ,f 'hook + (lambda (,orig &rest ,ll) + (when (hook-enabled ,fun) + (destructuring-bind ,lambda-list ,ll + (block hook + ,@body))) + (apply ,orig ,ll)))))) +(defmacro disable-hook (fun) + (let ((f (gensym))) + `(let ((,f ',fun)) + (when (nth-value 1 (gethash ,f *hook-enabled*)) + (setf (gethash ',fun *hook-enabled*) nil))))) +(defmacro enable-hook (fun) + (let ((f (gensym))) + `(let ((,f ',fun)) + (when (nth-value 1 (gethash ,f *hook-enabled*)) + (setf (gethash ',fun *hook-enabled*) t))))) +(defmacro unhook (fun) + (let ((f (gensym))) + `(let ((,f ',fun)) + (when (nth-value 1 (gethash ,f *hook-enabled*)) + (sb-int::unencapsulate ,f 'hook) + (remhash ,f *hook-enabled*))))) +(defmacro hook-enabled (fun) + `(gethash ',fun *hook-enabled*)) + +;; (defun test-hook (a b c &rest d) +;; (list (+ a b c) d)) +;; (hook test-hook (a b c &rest d) +;; (format t "This is a hook! ~A ~A ~A ~A~%" a b c d)) +;; (unhook test-hook) +;; (hook sb-c::compile-toplevel (lambdas load-time-value-p) +;; (format t "~%Hooking the compiler. compile-toplevel:~%lambdas: ~A~%load-time-value-p: ~A~%" +;; lambdas load-time-value-p)) +;; (unhook sb-c::compile-toplevel) +;; (eval-when (:compile-toplevel :load-toplevel) +;; (defvar *acc* nil)) +;; (hook sb-c::compile-component (component) +;; (push component *acc*)) + +(eval-when (:compile-toplevel :load-toplevel) + (defvar *trace-number* 0)) + +(hook sb-c::ir2-convert (component) + (disable-hook sb-c::ir2-convert) + (when (and (streamp sb-c::*compiler-trace-output*) + (find :sb-graph sb-c::*compile-trace-targets*)) + (let* ((pn (pathname sb-c::*compiler-trace-output*)) + (out-pn (make-pathname + :host (pathname-host pn) + :directory (pathname-directory pn) + :name + (format nil "trace-~A-~A" (incf *trace-number*) + (coerce (loop for char + across + (let ((cn (sb-c::component-name component))) + (cond + ((symbolp cn) (symbol-name cn)) + ((stringp cn) cn) + ((listp cn) (if (eq (car cn) 'top-level-form) + "TOP-LEVEL-FORM" + (format nil "~{~a~}" cn))) + (t ""))) + when (or (alpha-char-p char) + (digit-char-p char) + (char= char #\-) + (char= char #\_)) + collect char) + 'string)) + :type "dot"))) + (save-graph (render-graph (make-and-dfs component 9999999)) out-pn) + (when sb-c::*compile-progress* + (format *debug-io* "~%; Wrote graphviz of component ~A to ~A.~%" component out-pn)))) + (enable-hook sb-c::ir2-convert)) diff -Nru sbcl-2.1.1/contrib/sb-graph/src/package.lisp sbcl-2.1.11/contrib/sb-graph/src/package.lisp --- sbcl-2.1.1/contrib/sb-graph/src/package.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-graph/src/package.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,10 @@ +(eval-when (:compile-toplevel :load-toplevel) + (sb-ext:unlock-package :sb-c)) + +(defpackage :sb-graph + (:shadow :stream) + (:use :cl :cl-user) + (:export :hook :disable-hook :enable-hook :unhook :hook-enabled + :make-graph :make-and-dfs :save-graph :graph :render-graph + :expand :expand-codename :get-node-from-codename :expand :unexpand :get-node + :interactively-graph :output :dfs-add)) diff -Nru sbcl-2.1.1/contrib/sb-grovel/def-to-lisp.lisp sbcl-2.1.11/contrib/sb-grovel/def-to-lisp.lisp --- sbcl-2.1.1/contrib/sb-grovel/def-to-lisp.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-grovel/def-to-lisp.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -119,12 +119,12 @@ (as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long long) (long) (x): (x))") #+(and (not win32) x86-64) (as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long) (int) (x): (x))") - ;; the C compiler on macOS warns that %ld is the wrong format for an int + ;; the C compiler on x86 macOS warns that %ld is the wrong format for an int ;; even though 'long' and 'int' are both 4 bytes. - #+x86 - (as-c "#define CAST_SIGNED(x) ((long) (x))") - #-(or x86 x86-64) + #-(or x86 64-bit) (as-c "#define CAST_SIGNED(x) ((int) (x))") + #+(and (not x86-64) (or x86 64-bit)) + (as-c "#define CAST_SIGNED(x) ((long) (x))") (as-c "int main(int argc, char *argv[]) {") (as-c " FILE *out;") (as-c " if (argc != 2) {") diff -Nru sbcl-2.1.1/contrib/sb-introspect/introspect.lisp sbcl-2.1.11/contrib/sb-introspect/introspect.lisp --- sbcl-2.1.1/contrib/sb-introspect/introspect.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-introspect/introspect.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -34,6 +34,7 @@ "FUNCTION-ARGLIST" "FUNCTION-LAMBDA-LIST" "FUNCTION-TYPE" + "METHOD-COMBINATION-LAMBDA-LIST" "DEFTYPE-LAMBDA-LIST" "VALID-FUNCTION-NAME-P" "FIND-DEFINITION-SOURCE" @@ -300,11 +301,11 @@ (eq (car name) 'setf)) (setf name (cadr name))) (let ((expander (info :setf :expander name))) - (when expander - (find-definition-source - (cond ((symbolp expander) (symbol-function expander)) - ((listp expander) (cdr expander)) - (t expander)))))) + (cond ((typep expander '(cons symbol)) + (translate-source-location (cddr expander))) + (expander + (find-definition-source + (if (listp expander) (cdr expander) expander)))))) ((:structure) (let ((class (get-class name))) (if class @@ -492,11 +493,13 @@ (function-lambda-list function)) (defun function-lambda-list (function) - "Describe the lambda list for the extended function designator FUNCTION. + "Return the lambda list for the extended function designator FUNCTION. Works for special-operators, macros, simple functions, interpreted functions, and generic functions. Signals an error if FUNCTION is not a valid extended -function designator." - ;; FIXME: sink this logic into SB-KERNEL:%FUN-LAMBDA-LIST and just call that? +function designator. + +If the function does not have a lambda list (compiled with debug 0), +then two values are returned: (values nil t)" (cond ((and (symbolp function) (special-operator-p function)) (function-lambda-list (info :function :ir1-convert function))) ((valid-function-name-p function) @@ -506,7 +509,10 @@ ((typep function 'generic-function) (sb-pcl::generic-function-pretty-arglist function)) (t - (%fun-lambda-list function)))) + (let ((raw-result (%fun-lambda-list function))) + (if (eq raw-result :unknown) + (values nil t) + (values raw-result nil)))))) (defun deftype-lambda-list (typespec-operator) "Returns the lambda list of TYPESPEC-OPERATOR as first return @@ -521,6 +527,18 @@ (values (%fun-lambda-list f) t) (values nil nil)))) +(defun method-combination-lambda-list (method-combination) + "Return the lambda-list of METHOD-COMBINATION designator. +METHOD-COMBINATION can be a method combination object, +or a method combination name." + (let* ((name (etypecase method-combination + (symbol method-combination) + (method-combination + (sb-pcl::method-combination-type-name method-combination)))) + (info (or (gethash name sb-pcl::**method-combinations**) + (error "~S: no such method combination." name)))) + (sb-pcl::method-combination-info-lambda-list info))) + (defun function-type (function-designator) "Returns the ftype of FUNCTION-DESIGNATOR, or NIL." (etypecase function-designator @@ -541,7 +559,7 @@ ;; because it contains more accurate information e.g. for ;; struct-accessors. (function-type name) - (sb-impl::%fun-type function-designator)))))) + (sb-impl::%fun-ftype function-designator)))))) ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME @@ -784,22 +802,26 @@ ;; bits are packed in the opposite order. And thankfully, ;; this fix seems not to depend on whether the numbering ;; scheme is MSB 0 or LSB 0, afaict. - (let* ((index (sb-vm:find-page-index + (let* ((wp + (let ((card-index + (logand + (ash (get-lisp-obj-address object) ; pinned above + (- (integer-length (1- sb-vm:gencgc-card-bytes)))) + (sb-alien:extern-alien "gc_card_table_mask" sb-alien:int)))) + (eql 1 (sb-sys:sap-ref-8 + (sb-alien:extern-alien "gc_card_mark" + sb-sys:system-area-pointer) + card-index)))) + (index (sb-vm:find-page-index (get-lisp-obj-address object))) (flags (sb-alien:slot page 'sb-vm::flags)) . - ;; The unused WP-CLR is for ease of counting #+big-endian ((type (ldb (byte 5 3) flags)) - (wp (logbitp 2 flags)) - (wp-clr (logbitp 1 flags)) (dontmove (logbitp 0 flags))) #+little-endian ((type (ldb (byte 5 0) flags)) - (wp (logbitp 5 flags)) - (wp-clr (logbitp 6 flags)) (dontmove (logbitp 7 flags)))) - (declare (ignore wp-clr)) (list :space space :generation (sb-alien:slot page 'sb-vm::gen) :write-protected wp diff -Nru sbcl-2.1.1/contrib/sb-introspect/test-driver.lisp sbcl-2.1.11/contrib/sb-introspect/test-driver.lisp --- sbcl-2.1.1/contrib/sb-introspect/test-driver.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-introspect/test-driver.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -28,15 +28,23 @@ (deftest function-lambda-list.1 (function-lambda-list 'cl-user::one) - (cl-user::a cl-user::b cl-user::c)) + (cl-user::a cl-user::b cl-user::c) + nil) + +(deftest function-lambda-list.1a + (function-lambda-list 'cl-user::0-debug) + () + t) (deftest function-lambda-list.2 (function-lambda-list 'the) - (sb-c::value-type sb-c::form)) + (sb-c::value-type sb-c::form) + nil) (deftest function-lambda-list.3 (function-lambda-list #'(sb-pcl::slow-method cl-user::j (t))) - (sb-pcl::method-args sb-pcl::next-methods)) + (sb-pcl::method-args sb-pcl::next-methods) + nil) (deftest macro-lambda-list.1 (equal (function-lambda-list (defmacro macro-lambda-list.1-m (x b) @@ -320,6 +328,24 @@ (&optional sb-kernel::element-type sb-kernel::size) t) +;;; Check correctness of METHOD-COMBINATION-LAMBDA-LIST +(deftest method-combination-lambda-list.1 + (method-combination-lambda-list 'standard) + nil) + +(deftest method-combination-lambda-list.2 + (method-combination-lambda-list + (sb-mop:find-method-combination #'documentation 'cl-user::r nil)) + (&optional (sb-pcl::order :most-specific-first))) + +(declaim (sb-ext:muffle-conditions style-warning)) +(define-method-combination long-form-mc (foo &rest args &key bar) ()) + +(deftest method-combination-lambda-list.3 + (method-combination-lambda-list 'long-form-mc) + (foo &rest args &key bar)) + + ;;; Test allocation-information (defun tai (x kind info &key ignore) @@ -384,7 +410,7 @@ (setq sb-ext:*evaluator-mode* :compile) (sb-ext:defglobal *large-obj* nil) -#+(and gencgc (or riscv x86 x86-64 ppc) (not win32)) +#+(and gencgc (or riscv x86 x86-64 ppc) (not win32) (not ubsan)) (progn (setq *print-array* nil) (setq *large-obj* (make-array (* sb-vm:gencgc-card-bytes 4) diff -Nru sbcl-2.1.1/contrib/sb-introspect/test.lisp sbcl-2.1.11/contrib/sb-introspect/test.lisp --- sbcl-2.1.1/contrib/sb-introspect/test.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-introspect/test.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -93,3 +93,5 @@ (flet ((x ())) (declare (notinline x)) (x))) + +(defun 0-debug (a b c) (declare (optimize (debug 0))) (+ a b c)) diff -Nru sbcl-2.1.1/contrib/sb-md5/md5.lisp sbcl-2.1.11/contrib/sb-md5/md5.lisp --- sbcl-2.1.1/contrib/sb-md5/md5.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-md5/md5.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -374,7 +374,7 @@ block (* vm:vector-data-offset vm:word-bits) (* 64 vm:byte-bits)) #+(and :sbcl :little-endian) - (sb-kernel:ub8-bash-copy buffer offset block 0 64) + (sb-kernel:%byte-blt buffer offset block 0 64) #-(or (and :sbcl :little-endian) (and :cmu :little-endian)) (loop for i of-type (integer 0 16) from 0 for j of-type (integer 0 #.most-positive-fixnum) @@ -394,13 +394,14 @@ (type simple-string buffer) (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))) + (declare (ignorable block buffer offset)) #+(and :cmu :little-endian) (kernel:bit-bash-copy buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) block (* vm:vector-data-offset vm:word-bits) (* 64 vm:byte-bits)) #+(and :sbcl :little-endian) - (sb-kernel:ub8-bash-copy buffer offset block 0 64) + (error "Unexpectedly hit MD5:FILL-BLOCK-CHAR") #-(or (and :sbcl :little-endian) (and :cmu :little-endian)) (loop for i of-type (integer 0 16) from 0 for j of-type (integer 0 #.most-positive-fixnum) @@ -639,10 +640,7 @@ "Calculate the MD5 message-digest of data in `sequence', which should be a 1d simple-array with element type (unsigned-byte 8). On CMU CL and SBCL non-simple and non-1d arrays with this element-type are also -supported. Use with strings is DEPRECATED, since this will not work -correctly on implementations with `char-code-limit' > 256 and ignores -character-coding issues. Use md5sum-string instead, or convert to the -required (unsigned-byte 8) format through other means before-hand." +supported." (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) (type (vector (unsigned-byte 8)) sequence) (type fixnum start)) (locally diff -Nru sbcl-2.1.1/contrib/sb-posix/interface.lisp sbcl-2.1.11/contrib/sb-posix/interface.lisp --- sbcl-2.1.1/contrib/sb-posix/interface.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-posix/interface.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -128,7 +128,7 @@ (macrolet ((def (x) `(progn (define-call-internally open-with-mode ,x int minusp - (pathname filename) (flags int) (mode mode-t)) + (pathname filename) (flags int) &optional (mode mode-t)) (define-call-internally open-without-mode ,x int minusp (pathname filename) (flags int)) (define-entry-point ,x @@ -245,9 +245,10 @@ (define-call-internally fcntl-without-arg "fcntl" int minusp (fd file-descriptor) (cmd int)) (define-call-internally fcntl-with-int-arg "fcntl" int minusp - (fd file-descriptor) (cmd int) (arg int)) + (fd file-descriptor) (cmd int) &optional (arg int)) (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp (fd file-descriptor) (cmd int) + &optional (arg alien-pointer-to-anything-or-nil)) (define-protocol-class flock alien-flock () ((type :initarg :type :accessor flock-type @@ -364,7 +365,7 @@ ;; but newborn threads are not exposed in SB-THREAD:LIST-ALL-THREADS. ;; So we need to go lower-level to sense whether any exist. (sb-thread:avltree-list sb-thread::*all-threads*))) - #+sb-thread (sb-impl::finalizer-thread-start) + (sb-impl::finalizer-thread-start) (error "Cannot fork with multiple threads running.")) (let ((pid (posix-fork))) #+darwin (when (= pid 0) (darwin-reinit)) @@ -442,14 +443,12 @@ (declaim (inline wait)) (defun wait (&optional statusptr) (declare (type (or null (simple-array (signed-byte 32) (1))) statusptr)) - (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (sb-sys:with-pinned-objects (ptr) - (alien-funcall - (extern-alien "wait" (function pid-t (* int))) - (sb-sys:vector-sap ptr))))) - (if (minusp pid) - (syscall-error 'wait) - (values pid (aref ptr 0)))))) + (with-alien ((wait (function pid-t (* int)) :extern "wait") + (status int)) + (let ((pid (alien-funcall wait (addr status)))) + (when (minusp pid) (syscall-error 'wait)) + (when statusptr (setf (aref statusptr 0) status)) + (values pid status))))) #-win32 (progn @@ -459,15 +458,12 @@ (declare (type (sb-alien:alien pid-t) pid) (type (sb-alien:alien int) options) (type (or null (simple-array (signed-byte 32) (1))) statusptr)) - (let* ((ptr (or statusptr (make-array 1 :element-type '(signed-byte 32)))) - (pid (sb-sys:with-pinned-objects (ptr) - (alien-funcall - (extern-alien "waitpid" (function pid-t - pid-t (* int) int)) - pid (sb-sys:vector-sap ptr) options)))) - (if (minusp pid) - (syscall-error 'waitpid) - (values pid (aref ptr 0))))) + (with-alien ((waitpid (function pid-t pid-t (* int) int) :extern "waitpid") + (status int)) + (let ((pid (alien-funcall waitpid pid (addr status) options))) + (when (minusp pid) (syscall-error 'waitpid)) + (when statusptr (setf (aref statusptr 0) status)) + (values pid status)))) ;; waitpid macros (define-call "wifexited" boolean never-fails (status int)) (define-call "wexitstatus" int never-fails (status int)) @@ -664,16 +660,13 @@ (declaim (inline pipe)) (defun pipe (&optional filedes2) (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2)) - (unless filedes2 - (setq filedes2 (make-array 2 :element-type '(signed-byte 32)))) - (let ((r (sb-sys:with-pinned-objects (filedes2) - (alien-funcall - ;; FIXME: (* INT)? (ARRAY INT 2) would be better - (extern-alien "pipe" (function int (* int))) - (sb-sys:vector-sap filedes2))))) - (when (minusp r) - (syscall-error 'pipe))) - (values (aref filedes2 0) (aref filedes2 1)))) + (multiple-value-bind (fd0 fd1) + (with-alien ((pipe (function int (array int 2)) :extern "pipe") + (fds (array int 2))) + (let ((r (alien-funcall pipe fds))) + (if (minusp r) (syscall-error 'pipe) (values (deref fds 0) (deref fds 1))))) + (when filedes2 (setf (aref filedes2 0) fd0 (aref filedes2 1) fd1)) + (values fd0 fd1)))) #-win32 (define-protocol-class termios alien-termios () diff -Nru sbcl-2.1.1/contrib/sb-posix/macros.lisp sbcl-2.1.11/contrib/sb-posix/macros.lisp --- sbcl-2.1.1/contrib/sb-posix/macros.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-posix/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -99,16 +99,18 @@ (if (sb-sys:find-foreign-symbol-address c-name) `(progn (declaim (inline ,lisp-name)) - (defun ,lisp-name ,(mapcar #'car arguments) + (defun ,lisp-name ,(mapcar #'car (remove '&optional arguments)) (let ((r (alien-funcall (extern-alien ,c-name (function ,return-type ,@(mapcar (lambda (x) - (gethash (cadr x) - *designator-types* - (cadr x))) + (if (eq x '&optional) + x + (gethash (cadr x) + *designator-types* + (cadr x)))) arguments))) ,@(mapcar (lambda (x) (if (nth-value 1 @@ -118,7 +120,7 @@ :sb-posix) ,(car x)) (car x))) - arguments)))) + (remove '&optional arguments))))) (if (,error-predicate r) (syscall-error ',lisp-name) r)))) `(sb-int:style-warn "Didn't find definition for ~S" ,c-name))) diff -Nru sbcl-2.1.1/contrib/sb-posix/posix-tests.lisp sbcl-2.1.11/contrib/sb-posix/posix-tests.lisp --- sbcl-2.1.1/contrib/sb-posix/posix-tests.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-posix/posix-tests.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -563,7 +563,8 @@ (directory (make-pathname :name :wild :type :wild - :defaults *current-directory*)))) + :defaults *current-directory*) + :resolve-symlinks nil))) #'string<)) (sb-posix:closedir dir))) t) diff -Nru sbcl-2.1.1/contrib/sb-posix/strtod.lisp sbcl-2.1.11/contrib/sb-posix/strtod.lisp --- sbcl-2.1.1/contrib/sb-posix/strtod.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-posix/strtod.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -28,7 +28,7 @@ (when (typep string 'base-string) (sb-kernel:with-array-data ((data string) (start) (end) :check-fill-pointer t) (when (eql (locally - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (schar data (1+ end))) #\Nul) (return-from strtod (strtod/base-string data start))))) ;; Short simple non-base string, or base-string w/o a null in the right place diff -Nru sbcl-2.1.1/contrib/sb-rotate-byte/compiler.lisp sbcl-2.1.11/contrib/sb-rotate-byte/compiler.lisp --- sbcl-2.1.1/contrib/sb-rotate-byte/compiler.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-rotate-byte/compiler.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -87,6 +87,6 @@ ;;; first crack at a zero COUNT, since transforms are currently run ;;; latest-defined first. (deftransform %rotate-byte ((count size pos integer) - ((constant-arg (member 0)) * * *) *) + ((constant-arg (member 0)) t t t) *) "fold identity operation" 'integer) diff -Nru sbcl-2.1.1/contrib/sb-simple-streams/impl.lisp sbcl-2.1.11/contrib/sb-simple-streams/impl.lisp --- sbcl-2.1.1/contrib/sb-simple-streams/impl.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-simple-streams/impl.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,6 +12,7 @@ (eval-when (:compile-toplevel) (defun optional+key-style-warning-p (condition) (and (typep condition '(and simple-condition style-warning)) + (stringp (simple-condition-format-control condition)) (search "&OPTIONAL and &KEY found" (simple-condition-format-control condition)))) (proclaim '(sb-ext:muffle-conditions (satisfies optional+key-style-warning-p)))) diff -Nru sbcl-2.1.1/contrib/sb-simple-streams/sb-simple-streams.asd sbcl-2.1.11/contrib/sb-simple-streams/sb-simple-streams.asd --- sbcl-2.1.1/contrib/sb-simple-streams/sb-simple-streams.asd 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-simple-streams/sb-simple-streams.asd 2021-11-30 16:16:46.000000000 +0000 @@ -14,13 +14,13 @@ ;;(:file "ext-format" :depends-on ("package")) (:file "classes" :depends-on ("iodefs")) (:file "internal" :depends-on ("classes")) - (:file "strategy" :depends-on ("internal")) + (:file "strategy" :depends-on ("string")) (:file "impl" :depends-on ("internal" "fndb" "file" "string")) (:file "file" :depends-on ("strategy")) (:file "direct" :depends-on ("strategy")) (:file "null" :depends-on ("strategy")) (:file "socket" :depends-on ("strategy")) - (:file "string" :depends-on ("strategy")) + (:file "string" :depends-on ("internal")) (:file "terminal" :depends-on ("strategy")) ;;(:file "gray-compat" :depends-on ("package")) ) diff -Nru sbcl-2.1.1/contrib/sb-sprof/design-notes.txt sbcl-2.1.11/contrib/sb-sprof/design-notes.txt --- sbcl-2.1.1/contrib/sb-sprof/design-notes.txt 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/design-notes.txt 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,50 @@ +New data recorder: + +* Each thread gets its own trace buffer. + +* There are almost no mutexes involved nor any WITHOUT-GCING + nor synchronized hash-table. + +* Trace buffers store the program counter locations as code serial# + and displacement so that they are stable across GC. + +* For gencgc only, code on a pseudo-static page will store absolute PCs + which avoids looking for the object base address while sampling. + Therefore profiling a saved core is far more efficient. + +* Traces are hashed so that multiple hits at the same call stack + will entail only an increment of a counter for that trace. + This optimization makes :ALLOC mode collect far fewer traces + since many allocations have the same call stack. + +Known limitations: + +* A code object that gets GC'd after it has been recorded as serial# + displacement + may show up as an unknown function in the report. We could be slightly better + here by marking code objects as ineligible for GC if they appear in a profile buffer, + or we could have GC scan the profile buffers (which would defeat + the point of the stable representation), or we could just make all code ineligible + for GC if any profile buffers exist. + +* The code serial# field wraps around at 32 bits for 64-bit machines + (and 18 bits for 32-bit machines), which is a theoretical problem, but unlikely + to be a problem in practice. We could create a recycle list for serial# + assignment if it were ever a problem in practice. + The be on the safe side, the logic which assigs the number should refuse to + allocate new numbers after it hits the limit. Subsequently allocated code objects + would all get the number 0. + +* Non-x86 can still not walk more than one stack frame back. + This seems to have to do with the fact that it is unreliable (i.e. crash-prone) + to try to walk the stack when interrupted at an arbitrary instruction, because + our frame establishing instructions are not atomic. + This is contrary to most machine-native ABIs where the specification + is that frame creation be be atomic. e.g. on ppc it's a store-with-update. + +* The "missing frames" marker probably probably needs better treatment + if it occurs in a graph-based report so that the generator does not think + than all "missing frames" pseudo-functions are the same function. + +* The graphing routine does not currently take advantage of the compressed + representation of traces with multiple hits, so it takes more time than + should be required to preprocess the graph. diff -Nru sbcl-2.1.1/contrib/sb-sprof/disassemble.lisp sbcl-2.1.11/contrib/sb-sprof/disassemble.lisp --- sbcl-2.1.1/contrib/sb-sprof/disassemble.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/disassemble.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -8,7 +8,7 @@ (defun sample-counts-by-pc (samples) (let* ((unique-pc-count-guess (isqrt (truncate (samples-index samples) 2))) (sample-counts-by-pc (make-hash-table :size unique-pc-count-guess))) - (map-all-samples (lambda (info pc-or-offset) + (map-all-pc-locs (lambda (info pc-or-offset) (let ((pc (sample-pc info pc-or-offset))) (incf (gethash pc sample-counts-by-pc 0)))) samples) @@ -46,16 +46,15 @@ (defun add-disassembly-profile-note (chunk stream dstate) (declare (ignore chunk stream)) - (when *samples* - (let* ((samples *samples*) - (counts (ensure-sample-counts samples)) - (location (sb-disassem:dstate-cur-addr dstate)) - (count (pc-sample-count location counts))) + (binding* ((samples *samples* :exit-if-null) + (counts (ensure-sample-counts samples)) + (location (sb-disassem:dstate-cur-addr dstate)) + (count (pc-sample-count location counts))) (unless (zerop count) (let* ((total-count (samples-trace-count samples)) (width (length (write-to-string total-count :base 10)))) (sb-disassem::note (format nil "~VD/~VD samples" width count width total-count) - dstate)))))) + dstate))))) (pushnew 'add-disassembly-profile-note sb-disassem::*default-dstate-hooks*) diff -Nru sbcl-2.1.1/contrib/sb-sprof/graph.lisp sbcl-2.1.11/contrib/sb-sprof/graph.lisp --- sbcl-2.1.1/contrib/sb-sprof/graph.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/graph.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,10 +14,10 @@ (root nil :type (or null vertex)) (dfn 0 :type fixnum) (edges () :type list) - (scc-vertices () :type list)) + (scc-vertices () :type list :read-only t)) (defstruct edge - (vertex (sb-impl::missing-arg) :type vertex)) + (vertex (sb-int:missing-arg) :type vertex)) (defstruct graph (vertices () :type list)) @@ -147,15 +147,16 @@ (:constructor %make-call-graph)) ;; the value of *SAMPLE-INTERVAL* or *ALLOC-INTERVAL* at the time ;; the graph was created (depending on the current allocation mode) - (sample-interval (sb-impl::missing-arg) :type (real (0))) + (sample-interval (sb-int:missing-arg) :type (real (0)) :read-only t) ;; the sampling-mode that was used for the profiling run - (sampling-mode (sb-impl::missing-arg) :type sampling-mode) + (sampling-mode (sb-int:missing-arg) :type sampling-mode :read-only t) ;; number of samples taken - (nsamples (sb-impl::missing-arg) :type sb-int:index) + (nsamples (sb-int:missing-arg) :type sb-int:index :read-only t) + (unique-trace-count (sb-int:missing-arg) :type sb-int:index :read-only t) ;; threads that have been sampled - (sampled-threads '() :type list) + (sampled-threads '() :type list :read-only t) ;; sample count for samples not in any function - (elsewhere-count (sb-impl::missing-arg) :type sb-int:index)) + (elsewhere-count (sb-int:missing-arg) :type sb-int:index :read-only t)) (defmethod print-object ((call-graph call-graph) stream) (print-unreadable-object (call-graph stream :type t :identity t) @@ -181,13 +182,13 @@ (start-pc-or-offset 0 :type address) (end-pc-or-offset 0 :type address) ;; the name of the function - (name nil :type t) + (name nil :type t :read-only t) ;; sample count for this function (count 0 :type fixnum) ;; count including time spent in functions called from this one (accrued-count 0 :type fixnum) ;; the debug-info that this node was created from - (debug-info nil :type t) + (debug-info nil :type t :read-only t) ;; list of NODEs for functions calling this one (callers () :type list) ;; the call count for the function that corresponds to this node (or NIL @@ -253,7 +254,11 @@ ;;; Make a NODE for debug-info INFO. (defun make-node (info) - (flet ((clean-name (name) + (flet ((code-bounds (code) + (let* ((start (sb-kernel:code-instructions code)) + (end (sap+ start (sb-kernel:%code-text-size code)))) + (values (sap-int start) (sap-int end)))) + (clean-name (name) (if (and (consp name) (member (first name) '(sb-c::xep sb-c::tl-xep sb-c::&more-processor @@ -262,7 +267,7 @@ (second name) name))) (typecase info - (sb-kernel::code-component + (sb-kernel:code-component (multiple-value-bind (start end) (code-bounds info) (values @@ -335,7 +340,7 @@ collect node)) ;;; Value is a CALL-GRAPH for the current contents of *SAMPLES*. -(defun make-call-graph-1 (max-depth) +(defun make-call-graph-1 (samples max-depth) (let ((elsewhere-count 0)) (with-lookup-tables () (map-traces @@ -345,7 +350,7 @@ (depth 0) (caller nil)) (block calls - (map-trace-samples + (map-trace-pc-locs (lambda (debug-info pc-offset) (declare (ignore pc-offset)) (when (> depth max-depth) @@ -373,17 +378,17 @@ (incf (node-accrued-count caller))) (t (incf elsewhere-count))))) - *samples*) + samples) (let ((sorted-nodes (sort (collect-nodes) #'> :key #'node-count))) (loop for node in sorted-nodes and i from 1 do (setf (node-index node) i)) - (%make-call-graph :nsamples (samples-trace-count *samples*) - :sample-interval (if (eq (samples-mode *samples*) - :alloc) - (samples-alloc-interval *samples*) - (samples-sample-interval *samples*)) - :sampling-mode (samples-mode *samples*) - :sampled-threads (samples-sampled-threads *samples*) + (%make-call-graph :nsamples (samples-trace-count samples) + :unique-trace-count (samples-unique-trace-count samples) + :sample-interval (if (eq (samples-mode samples) :alloc) + 1 + (samples-sample-interval samples)) + :sampling-mode (samples-mode samples) + :sampled-threads (samples-sampled-threads samples) :elsewhere-count elsewhere-count :vertices sorted-nodes))))) @@ -418,10 +423,19 @@ ;;; *SAMPLES*. The result contain a list of nodes sorted by self-time ;;; in the FLAT-NODES slot, and a dag in VERTICES, with call cycles ;;; reduced to CYCLE structures. -(defun make-call-graph (max-depth) +(defun make-call-graph (samples max-depth) (stop-profiling) - (show-progress "~&Computing call graph ") - (let ((call-graph (without-gcing (make-call-graph-1 max-depth)))) + (when (zerop (length (samples-vector samples))) + (show-progress "~&Aggregating raw data") + (setf (values (samples-vector samples) + (samples-unique-trace-count samples) + (samples-sampled-threads samples)) + (convert-raw-data))) + (show-progress "~&Computing call graph") + ;; I _think_ the reason for pinning all code is that the graph logic + ;; compares absolute PC locations. Wonderfully commented, it is. + (let ((call-graph (with-code-pages-pinned (:dynamic) + (make-call-graph-1 samples max-depth)))) (show-progress "~&Finding cycles") #+nil (reduce-call-graph call-graph) diff -Nru sbcl-2.1.1/contrib/sb-sprof/interface.lisp sbcl-2.1.11/contrib/sb-sprof/interface.lisp --- sbcl-2.1.1/contrib/sb-sprof/interface.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/interface.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,14 +9,8 @@ "Default number of seconds between samples.") (declaim (type (real (0)) *sample-interval*)) -(defvar *alloc-interval* 4 - "Default number of allocation region openings between samples.") -(declaim (type (integer (0)) *alloc-interval*)) - (defvar *max-samples* 50000 - "Default number of traces taken. This variable is somewhat misnamed: -each trace may actually consist of an arbitrary number of samples, depending -on the depth of the call stack.") + "Default maximum number of stack traces collected.") (declaim (type sb-int:index *max-samples*)) (defvar *sampling-mode* :cpu @@ -25,47 +19,35 @@ (declaim (type sampling-mode *sampling-mode*)) (defmacro with-profiling ((&key (sample-interval '*sample-interval*) - (alloc-interval '*alloc-interval*) + alloc-interval (max-samples '*max-samples*) (reset nil) (mode '*sampling-mode*) (loop nil) - (max-depth most-positive-fixnum) + max-depth show-progress - (threads '(list sb-thread:*current-thread*)) + (threads :all) (report nil report-p)) &body body) "Evaluate BODY with statistical profiling turned on. If LOOP is true, loop around the BODY until a sufficient number of samples has been collected. Returns the values from the last evaluation of BODY. -In multithreaded operation, only the thread in which WITH-PROFILING was -evaluated will be profiled by default. If you want to profile multiple -threads, invoke the profiler with START-PROFILING. - The following keyword args are recognized: :SAMPLE-INTERVAL Take a sample every seconds. Default is *SAMPLE-INTERVAL*. - :ALLOC-INTERVAL - Take a sample every time allocation regions (approximately - 8kB) have been allocated since the last sample. Default is - *ALLOC-INTERVAL*. - :MODE If :CPU, run the profiler in CPU profiling mode. If :ALLOC, run the profiler in allocation profiling mode. If :TIME, run the profiler in wallclock profiling mode. :MAX-SAMPLES - Repeat evaluating body until samples are taken. + If :LOOP is NIL (the default), collect no more than samples. + If :LOOP is T, repeat evaluating body until samples are taken. Default is *MAX-SAMPLES*. - :MAX-DEPTH - Maximum call stack depth that the profiler should consider. Only - has an effect on x86 and x86-64. - :REPORT If specified, call REPORT with :TYPE at the end. @@ -74,8 +56,7 @@ :THREADS Form that evaluates to the list threads to profile, or :ALL to indicate - that all threads should be profiled. Defaults to the current - thread. (Note: START-PROFILING defaults to all threads.) + that all threads should be profiled. Defaults to all threads. :THREADS has no effect on call-counting at the moment. @@ -90,78 +71,67 @@ evaluate BODY." (declare (type report-type report)) (check-type loop boolean) - (with-unique-names (values last-index oops) - `(let* ((*sample-interval* ,sample-interval) - (*alloc-interval* ,alloc-interval) - (*sampling* nil) - (*sampling-mode* ,mode) - (*max-samples* ,max-samples)) - ,@(when reset '((reset))) - (flet ((,oops () - (warn "~@"))) + #-sb-thread (unless (eq threads :all) (warn ":THREADS is ignored")) + (when alloc-interval (warn "ALLOC-INTERVAL is ignored")) + (when max-depth (warn "MAX-DEPTH is ignored")) + (let ((message "~@")) + (with-unique-names (values last-index) + `(let ((*show-progress* ,show-progress)) + ,@(when reset '((reset))) (unwind-protect (progn - (start-profiling :max-depth ,max-depth :threads ,threads) + (start-profiling :mode ,mode :max-samples ,max-samples + :sample-interval ,sample-interval + :threads ,threads) ,(if loop `(let (,values) - (loop - (when (>= (samples-trace-count *samples*) - (samples-max-samples *samples*)) + (loop ; Uh, shouldn't this be a trailing test, not a leading test? + (when (>= trace-count trace-limit) (return)) - ,@(when show-progress - `((format t "~&===> ~d of ~d samples taken.~%" - (samples-trace-count *samples*) - (samples-max-samples *samples*)))) - (let ((,last-index (samples-index *samples*))) + (show-progress "~&===> ~d of ~d samples taken.~%" + trace-count trace-limit) + (let ((,last-index trace-count)) (setf ,values (multiple-value-list (progn ,@body))) - (when (= ,last-index (samples-index *samples*)) - (,oops) + (when (= ,last-index trace-count) + (warn ,message) (return)))) (values-list ,values)) - `(let ((,last-index (samples-index *samples*))) + `(let ((,last-index trace-count)) (multiple-value-prog1 (progn ,@body) - (when (= ,last-index (samples-index *samples*)) - (,oops)))))) - (stop-profiling))) - ,@(when report-p `((report :type ,report)))))) + (when (= ,last-index trace-count) + (warn ,message)))))) + (stop-profiling)) + ,@(when report-p `((report :type ,report))))))) + +;;; In wallclock mode, *TIMER* is an instance of either SB-THREAD:THREAD +;;; or SB-EXT:TIMER depending on whether thread support exists. +(defglobal *timer* nil) #-win32 (defun start-profiling (&key (max-samples *max-samples*) (mode *sampling-mode*) (sample-interval *sample-interval*) - (alloc-interval *alloc-interval*) - (max-depth most-positive-fixnum) - (threads :all) - (sampling t)) + alloc-interval + max-depth + (threads :all)) "Start profiling statistically in the current thread if not already profiling. The following keyword args are recognized: :SAMPLE-INTERVAL Take a sample every seconds. Default is *SAMPLE-INTERVAL*. - :ALLOC-INTERVAL - Take a sample every time allocation regions (approximately - 8kB) have been allocated since the last sample. Default is - *ALLOC-INTERVAL*. - :MODE If :CPU, run the profiler in CPU profiling mode. If :ALLOC, run the profiler in allocation profiling mode. If :TIME, run the profiler in wallclock profiling mode. :MAX-SAMPLES - Maximum number of samples. Default is *MAX-SAMPLES*. - - :MAX-DEPTH - Maximum call stack depth that the profiler should consider. Only - has an effect on x86 and x86-64. + Maximum number of stack traces to collect. Default is *MAX-SAMPLES*. :THREADS List threads to profile, or :ALL to indicate that all threads should be - profiled. Defaults to :ALL. (Note: WITH-PROFILING defaults to the current - thread.) + profiled. Defaults to :ALL. :THREADS has no effect on call-counting at the moment. @@ -169,63 +139,68 @@ not properly delivered to threads in proportion to their CPU usage when doing :CPU profiling. If you see empty call graphs, or are obviously missing several samples from certain threads, you may be falling afoul - of this. - - :SAMPLING - If true, the default, start sampling right away. - If false, START-SAMPLING can be used to turn sampling on." + of this." + ;; Starting the clock with an interval of zero or negative is meaningless. + ;; If, by 0, you mean STOP-PROFILING then you should use STOP-PROFILING. + (declare (type (real (0)) sample-interval)) + (when alloc-interval (warn "ALLOC-INTERVAL is ignored")) + (when max-depth (warn "MAX-DEPTH is ignored")) #-gencgc (when (eq mode :alloc) (error "Allocation profiling is only supported for builds using the generational garbage collector.")) - (unless *profiling* - (multiple-value-bind (secs usecs) - (multiple-value-bind (secs rest) - (truncate sample-interval) - (values secs (truncate (* rest 1000000)))) - (setf *sampling* sampling - *samples* (make-samples :max-depth max-depth - :max-samples max-samples - :sample-interval sample-interval - :alloc-interval alloc-interval - :mode mode)) - (enable-call-counting) - (setf *profiled-threads* threads) - (sb-sys:enable-interrupt sb-unix:sigprof - #'sigprof-handler) - (flet (#+sb-thread - (map-threads (function &aux (threads *profiled-threads*)) - (if (listp threads) - (mapc function threads) - (named-let visit ((node sb-thread::*all-threads*)) - (awhen (sb-thread::avlnode-left node) (visit it)) - (awhen (sb-thread::avlnode-right node) (visit it)) - (let ((thread (sb-thread::avlnode-data node))) - (when (and (= (sb-thread::thread-%visible thread) 1) - (neq thread *timer*)) - (funcall function thread))))))) - (ecase mode - (:alloc - (let ((alloc-signal (1- alloc-interval))) - #+sb-thread - (progn - (when (eq :all threads) - ;; Set the value new threads inherit. - ;; This used to acquire the all-threads lock, but I fail to see how - ;; doing so ensured anything at all. Maybe because our locks tend - ;; to act as memory barriers? Anyway, what's the point? - (progn - (setf sb-thread::*default-alloc-signal* alloc-signal))) - ;; Turn on allocation profiling in existing threads. - (map-threads - (lambda (thread) - (sb-thread::%set-symbol-value-in-thread 'sb-vm::*alloc-signal* thread alloc-signal)))) - #-sb-thread - (setf sb-vm:*alloc-signal* alloc-signal))) - (:cpu - (unix-setitimer :profile secs usecs secs usecs)) - (:time - #+sb-thread - (sb-thread::start-thread + #-sb-thread (unless (eq threads :all) (warn ":THREADS is ignored")) + (when *profiling* + (warn "START-PROFILING will STOP-PROFILING first before applying new parameters") + (stop-profiling)) + ;; I'm 99% sure that unconditionally assigning *SAMPLES* is a bug, + ;; because doing it makes the RESET function (and the :RESET keyword + ;; to WITH-PROFILING) meaningless - what's the difference between + ;; resetting and not resetting if either way causes all previously + ;; acquired traces to disappear? My intuition would have been that + ;; start/stop/start/stop should leave *SAMPLES* holding a union of all + ;; traces captured by both "on" periods, whereas with a RESET in between + ;; it would not. But they behave identically, because this is a reset. + (setf *samples* (make-samples mode sample-interval)) + (setf trace-limit max-samples trace-count 0) + (enable-call-counting) + #+sb-thread (setf sb-thread::*profiled-threads* threads) + ;; Each existing threads' sprof-enable slot needs to reflect the desired set. + (sb-thread::avltree-filter + (lambda (node &aux (thread (sb-thread::avlnode-data node))) + (if (or (eq threads :all) (memq thread threads)) + (start-sampling thread) + (stop-sampling thread))) + sb-thread::*all-threads*) + ;; The signal handler is entirely in C now. install_handler() uses the argument + ;; as a boolean flag. -1 means "install", 0 means "uninstall" which we don't do. + ;; Statistical allocation profiling is not signal-based- instead, whenever a C call + ;; occurs to handle thread-local allocation region overflow, a trace is recorded. + (unless (eq mode :alloc) + (with-alien ((%sigaction (function void int signed) :extern "install_handler")) + (alien-funcall %sigaction sb-unix:sigprof -1))) + ;; Keep all code live no matter if apparently unreferenced + (setf (extern-alien "sb_sprof_enabled" int) 1) + (ecase mode + (:alloc + (setq enable-alloc-profiler 1)) + (:cpu + (multiple-value-bind (secs usecs) + (multiple-value-bind (secs rest) (truncate sample-interval) + (values secs (truncate (* rest 1000000)))) + (unix-setitimer :profile secs usecs secs usecs))) + (:time + #+sb-thread + (flet ((map-threads (function &aux (threads sb-thread::*profiled-threads*)) + (if (listp threads) + (mapc function threads) + (named-let visit ((node sb-thread::*all-threads*)) + (awhen (sb-thread::avlnode-left node) (visit it)) + (awhen (sb-thread::avlnode-right node) (visit it)) + (let ((thread (sb-thread::avlnode-data node))) + (when (and (= (sb-thread::thread-%visible thread) 1) + (neq thread *timer*)) + (funcall function thread))))))) + (sb-thread::start-thread (setf *timer* (sb-thread::%make-thread "SPROF timer" nil (sb-thread:make-semaphore))) (lambda () (loop (unless *timer* (return)) @@ -234,30 +209,24 @@ (lambda (thread) (sb-thread:with-deathlok (thread c-thread) (unless (= c-thread 0) - (sb-thread:pthread-kill (sb-thread::thread-os-thread thread) - sb-unix:sigprof))))))) - nil) - #-sb-thread - (schedule-timer - (setf *timer* (make-timer (lambda () (unix-kill 0 sb-unix:sigprof)) - :name "SPROF timer")) - sample-interval :repeat-interval sample-interval)))) - (setq *profiling* mode))) - (values)) + (sb-unix:pthread-kill (sb-thread::thread-os-thread thread) + sb-unix:sigprof))))))) + nil)) + #-sb-thread + (schedule-timer (setf *timer* (make-timer (lambda () (unix-kill 0 sb-unix:sigprof)) + :name "SPROF timer")) + sample-interval :repeat-interval sample-interval))) + (setq *profiling* mode)) (defun stop-profiling () "Stop profiling if profiling." (let ((profiling *profiling*)) (when profiling ;; Even with the timers shut down we cannot be sure that there is no - ;; undelivered sigprof. The handler is also responsible for turning the - ;; *ALLOC-SIGNAL* off in individual threads. + ;; undelivered sigprof. (ecase profiling (:alloc - #+sb-thread - (setf sb-thread::*default-alloc-signal* nil) - #-sb-thread - (setf sb-vm:*alloc-signal* nil)) + (setq enable-alloc-profiler 0)) (:cpu (unix-setitimer :profile 0 0 0 0)) (:time @@ -268,14 +237,18 @@ #-sb-thread (unschedule-timer timer) #+sb-thread (sb-thread:join-thread timer)))) (disable-call-counting) - (setf *profiling* nil - *sampling* nil - *profiled-threads* nil))) + ;; New threads should not mask SIGPROF by default + #+sb-thread (setf sb-thread::*profiled-threads* :all) + (let ((samples *samples*)) + (aver samples) + (setf (samples-trace-count samples) trace-count)) + (setf *profiling* nil))) (values)) (defun reset () "Reset the profiler." (stop-profiling) - (setq *sampling* nil) (setq *samples* nil) + (setf trace-count 0) + (call-with-each-profile-buffer (lambda (x y z) (declare (ignore x y z)))) (values)) diff -Nru sbcl-2.1.1/contrib/sb-sprof/package.lisp sbcl-2.1.11/contrib/sb-sprof/package.lisp --- sbcl-2.1.1/contrib/sb-sprof/package.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/package.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -8,7 +8,7 @@ (:export ;; Recording #:start-sampling #:stop-sampling #:with-sampling - #:map-traces #:map-trace-samples #:map-all-samples + #:map-traces #:sample-pc ;; Call counting @@ -19,7 +19,7 @@ #:report ;; Interface - #:*sample-interval* #:*max-samples* #:*alloc-interval* + #:*sample-interval* #:*max-samples* #:start-profiling #:stop-profiling #:with-profiling #:reset)) (eval-when (:compile-toplevel :load-toplevel :execute) diff -Nru sbcl-2.1.1/contrib/sb-sprof/record.lisp sbcl-2.1.11/contrib/sb-sprof/record.lisp --- sbcl-2.1.1/contrib/sb-sprof/record.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/record.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -5,9 +5,6 @@ (in-package #:sb-sprof) - -;;; Append-only sample vector - (deftype sampling-mode () '(member :cpu :alloc :time)) @@ -20,99 +17,26 @@ ;;; 1 the current thread, an SB-THREAD:THREAD instance (defconstant +elements-per-trace-start+ 2) -(declaim (inline make-sample-vector)) -(defun make-sample-vector (max-samples) - (make-array (* max-samples - ;; Arbitrary guess at how many pc-locs we'll be - ;; taking for each trace. The exact amount doesn't - ;; matter, this is just to decrease the amount of - ;; re-allocation that will need to be done. - 10 - ;; Each pc-loc takes two cells in the vector - +elements-per-pc-loc+))) - ;;; Encapsulate all the information about a sampling run -(defstruct (samples - (:constructor - make-samples (&key mode sample-interval alloc-interval - max-depth max-samples - &aux (vector (make-sample-vector max-samples))))) - ;; When this vector fills up, we allocate a new one and copy over - ;; the old contents. - (vector nil :type simple-vector) - (index 0 :type sb-int:index) - ;; Only used while recording a trace. Stores a cell that is - ;; - ;; (start-trace . nil) (start-trace is the marker symbol - ;; SB-SPROF:START-TRACE) - ;; - ;; when starting to record a trace and - ;; - ;; (start-trace . END-INDEX-OF-THE-TRACE) - ;; - ;; after finishing recording the trace. This allows MAP-TRACES to - ;; jump from one trace to the next in O(1) instead of O(N) time. - (trace-start '(nil . nil) :type cons) +(defstruct (samples (:constructor make-samples (mode sample-interval))) + (vector #() :type simple-vector) + ;; The trace count is updated only when profiling is stopped. (trace-count 0 :type sb-int:index) - + (unique-trace-count nil) (sampled-threads nil :type list) - ;; Metadata (mode nil :type sampling-mode :read-only t) - (sample-interval (sb-int:missing-arg) :type (real (0)) :read-only t) - (alloc-interval (sb-int:missing-arg) :type (integer (0)) :read-only t) - (max-depth most-positive-fixnum :type (and fixnum (integer (0))) :read-only t) - (max-samples (sb-int:missing-arg) :type sb-int:index :read-only t)) + (sample-interval (sb-int:missing-arg) :type (real (0)) :read-only t)) + +(defun samples-index (x) (length (samples-vector x))) + +(define-alien-variable ("gencgc_alloc_profiler" enable-alloc-profiler) (signed 32)) +(define-alien-variable ("sb_sprof_trace_ct" trace-count) (signed 32)) +(define-alien-variable ("sb_sprof_trace_ct_max" trace-limit) (signed 32)) (defmethod print-object ((samples samples) stream) (let ((*print-array* nil)) (call-next-method))) - -(defun note-sample-vector-full (samples) - (format *trace-output* "Profiler sample vector full (~:D trace~:P / ~ - approximately ~:D sample~:P), doubling the ~ - size~%" - (samples-trace-count samples) - (truncate (samples-index samples) +elements-per-pc-loc+))) - -(declaim (inline ensure-samples-vector)) -(defun ensure-samples-vector (samples) - (declare (optimize (speed 3))) - (let ((vector (samples-vector samples)) - (index (samples-index samples))) - ;; Allocate a new sample vector if the current one is too small to - ;; accommodate the largest chunk of elements that we could - ;; potentially store in one go (currently 3 elements, stored by - ;; RECORD-TRACE-START). - (values (if (< (length vector) (+ index (max +elements-per-pc-loc+ - +elements-per-trace-start+))) - (let ((new-vector (make-array (* 2 index)))) - (note-sample-vector-full samples) - (replace new-vector vector) - (setf (samples-vector samples) new-vector)) - vector) - index))) - -(defun record-trace-start (samples) - ;; Mark the start of the trace. - (multiple-value-bind (vector index) (ensure-samples-vector samples) - (let ((trace-start (cons 'trace-start nil))) - (setf (aref vector index) trace-start - (aref vector (+ index 1)) sb-thread:*current-thread*) - (setf (samples-index samples) (+ index +elements-per-trace-start+) - (samples-trace-start samples) trace-start)))) - -(defun record-trace-end (samples) - (setf (cdr (samples-trace-start samples)) (samples-index samples))) - -(declaim (inline record-sample)) -(defun record-sample (samples info pc-or-offset) - (multiple-value-bind (vector index) (ensure-samples-vector samples) - ;; For each sample, store the debug-info and the PC/offset into - ;; adjacent cells. - (setf (aref vector index) info - (aref vector (1+ index)) pc-or-offset) - (setf (samples-index samples) (+ index +elements-per-pc-loc+)))) ;;; Trace and sample and access functions @@ -123,7 +47,7 @@ FUNCTION is called once for each trace where THREAD is the SB-THREAD:TREAD instance which was sampled to produce TRACE, and TRACE is an opaque object -to be passed to MAP-TRACE-SAMPLES. +to be passed to MAP-TRACE-PC-LOCS. EXPERIMENTAL: Interface subject to change." (let ((function (sb-kernel:%coerce-callable-to-fun function)) @@ -138,15 +62,10 @@ do (let ((trace (list vector start end))) (funcall function thread trace)))))) -;;; FIXME: rename to MAP-TRACE-PC-LOCS, -;;; and also maybe rename SAMPLE-PC to PC-LOC-PC. -(defun map-trace-samples (function trace) - "Call FUNCTION on each sample in TRACE. - -The signature of FUNCTION must be compatible with (info pc-or-offset). -TRACE is an object as received by the function passed to MAP-TRACES. - -EXPERIMENTAL: Interface subject to change." +;;; Call FUNCTION on each PC location in TRACE. +;;; The signature of FUNCTION must be compatible with (info pc-or-offset). +;;; TRACE is an object as received by the function passed to MAP-TRACES. +(defun map-trace-pc-locs (function trace) (let ((function (sb-kernel:%coerce-callable-to-fun function))) (destructuring-bind (samples start end) trace (loop for i from (- end +elements-per-pc-loc+) @@ -156,25 +75,26 @@ for pc-or-offset = (aref samples (1+ i)) do (funcall function info pc-or-offset))))) -(declaim (special *samples*)) -(defun map-all-samples (function &optional (samples *samples*)) - "Call FUNCTION on each sample in SAMPLES. - -The signature of FUNCTION must be compatible with (info pc-or-offset). - -SAMPLES is usually the value of *SAMPLES* after a profiling run. +;;; One "sample" is a trace, usually. But also it means an instance of SAMPLES, +;;; but also it means a PC location expressed as code + offset. +;;; So when is a sample not a sample? When it's a PC location. +(declaim (type (or null samples) *samples*)) +(defglobal *samples* nil) -EXPERIMENTAL: Interface subject to change." +;;; Call FUNCTION on each PC location in SAMPLES which is usually +;;; the value of *SAMPLES* after a profiling run. +;;; The signature of FUNCTION must be compatible with (info pc-or-offset). +(defun map-all-pc-locs (function &optional (samples *samples*)) (sb-int:dx-flet ((do-trace (thread trace) (declare (ignore thread)) - (map-trace-samples function trace))) + (map-trace-pc-locs function trace))) (map-traces #'do-trace samples))) (defun sample-pc (info pc-or-offset) "Extract and return program counter from INFO and PC-OR-OFFSET. -Can be applied to the arguments passed by MAP-TRACE-SAMPLES and -MAP-ALL-SAMPLES. +Can be applied to the arguments passed by MAP-TRACE-PC-LOCS and +MAP-ALL-PC-LOCS. EXPERIMENTAL: Interface subject to change." (etypecase info @@ -185,19 +105,14 @@ ;; Lisp functions might move, so we've stored a offset from the ;; start of the code component. (sb-di::compiled-debug-fun - (let* ((component (sb-di::compiled-debug-fun-component info)) - (start-pc (code-start component))) - (+ start-pc pc-or-offset))))) + (let ((component (sb-di::compiled-debug-fun-component info))) + (sap-int (sap+ (sb-kernel:code-instructions component) pc-or-offset)))))) ;;; Sampling -(defvar *samples* nil) -(declaim (type (or null samples) *samples*)) - +;;; *PROFILING* is both the global enabling flag, and the operational mode. (defvar *profiling* nil) (declaim (type (or (eql nil) sampling-mode) *profiling*)) -(defvar *sampling* nil) -(declaim (type boolean *sampling*)) (defvar *show-progress* nil) @@ -209,27 +124,63 @@ (apply #'format t format-string args) (finish-output))) -(defun start-sampling () - "Switch on statistical sampling." - (setq *sampling* t)) - -(defun stop-sampling () - "Switch off statistical sampling." - (setq *sampling* nil)) +(define-alien-routine "sb_toggle_sigprof" int (context system-area-pointer) (state int)) +(eval-when (:compile-toplevel) + ;; current-thread-offset-sap has no slot setter, let alone for other threads, + ;; nor for sub-fields of a word, so ... + (defmacro sprof-enable-byte () ; see 'thread.h' + (+ (ash sb-vm:thread-state-word-slot sb-vm:word-shift) 1))) + +;;; If a thread wants sampling but had previously blocked SIGPROF, +;;; it will have to unblock the signal. We can use %INTERRUPT-THREAD +;;; to tell it to do that. +(defun start-sampling (&optional (thread sb-thread:*current-thread*)) + "Unblock SIGPROF in the specified thread" + (if (eq thread sb-thread:*current-thread*) + (when (zerop (sap-ref-8 (sb-thread:current-thread-sap) (sprof-enable-byte))) + (setf (sap-ref-8 (sb-thread:current-thread-sap) (sprof-enable-byte)) 1) + (sb-toggle-sigprof (if (boundp 'sb-kernel:*current-internal-error-context*) + sb-kernel:*current-internal-error-context* + (sb-sys:int-sap 0)) + 0)) + ;; %INTERRUPT-THREAD requires that the interruptions lock be held by the caller. + (sb-thread:with-deathlok (thread c-thread) + (when (and (/= c-thread 0) + (zerop (sap-ref-8 (int-sap c-thread) (sprof-enable-byte)))) + (sb-thread::%interrupt-thread thread #'start-sampling)))) + nil) + +(defun stop-sampling (&optional (thread sb-thread:*current-thread*)) + "Block SIGPROF in the specified thread" + (sb-thread:with-deathlok (thread c-thread) + (when (and (/= c-thread 0) + (not (zerop (sap-ref-8 (int-sap c-thread) (sprof-enable-byte))))) + (setf (sap-ref-8 (int-sap c-thread) (sprof-enable-byte)) 0) + ;; Blocking the signal is done lazily in threads other than the current one. + (when (eq thread sb-thread:*current-thread*) + (sb-toggle-sigprof (sb-sys:int-sap 0) 1)))) ; 1 = mask it + nil) + +(defun call-with-sampling (enable thunk) + (declare (dynamic-extent thunk)) + (if (= (sap-ref-8 (sb-thread:current-thread-sap) (sprof-enable-byte)) + (if enable 1 0)) + ;; Already in the correct state + (funcall thunk) + ;; Invert state, call thunk, invert again + (progn (if enable (start-sampling) (stop-sampling)) + (unwind-protect (funcall thunk) + (if enable (stop-sampling) (start-sampling)))))) (defmacro with-sampling ((&optional (on t)) &body body) - "Evaluate body with statistical sampling turned on or off." - `(let ((*sampling* ,on) - (sb-vm:*alloc-signal* sb-vm:*alloc-signal*)) - ,@body)) + "Evaluate body with statistical sampling turned on or off in the current thread." + `(call-with-sampling (if ,on t nil) (lambda () ,@body))) ;;; Return something serving as debug info for address PC. -(declaim (inline debug-info)) -(defun debug-info (pc) +(defun debug-info (pc code) (declare (type system-area-pointer pc) (muffle-conditions compiler-note)) - (let ((code (sb-di::code-header-from-pc pc)) - (pc-int (sap-int pc))) + (let ((pc-int (sap-int pc))) (cond ((not code) (let ((name (sap-foreign-symbol pc))) (if name @@ -240,9 +191,7 @@ (values (sb-disassem::find-assembler-routine pc-int) pc-int :asm-routine)) (t - (let* ((code-header-len (* (sb-kernel:code-header-words code) - sb-vm:n-word-bytes)) - ;; Give up if we land in the 2 or 3 instructions of a + (let* (;; Give up if we land in the 2 or 3 instructions of a ;; code component sans simple-fun that is not an asm routine. ;; While it's conceivable that this could be improved, ;; the problem will be different or nonexistent after @@ -252,159 +201,231 @@ 'sb-c::compiled-debug-info) (return-from debug-info (values code pc-int nil)))) - (pc-offset (- pc-int - (- (sb-kernel:get-lisp-obj-address code) - sb-vm:other-pointer-lowtag) - code-header-len)) + (pc-offset (sap- (int-sap pc-int) (sb-kernel:code-instructions code))) (df (sb-di::debug-fun-from-pc code pc-offset))) #+immobile-code (declare (ignorable di)) (cond ((typep df 'sb-di::bogus-debug-fun) (values code pc-int nil)) (df ;; The code component might be moved by the GC. Store - ;; a PC offset, and reconstruct the data in - ;; SAMPLE-PC-FROM-PC-OR-OFFSET. + ;; a PC offset, and reconstruct the data in SAMPLE-PC (values df pc-offset nil)) (t (values nil 0 nil)))))))) -(declaim (inline record)) -(defun record (samples pc) - (declare (type system-area-pointer pc)) - (multiple-value-bind (info pc-or-offset foreign) (debug-info pc) - (record-sample samples info pc-or-offset) - foreign)) - -;;; List of thread currently profiled, or :ALL for all threads. -(defvar *profiled-threads* nil) -(declaim (type (or list (member :all)) *profiled-threads*)) - -;;; In wallclock mode, *TIMER* is an instance of either SB-THREAD:THREAD -;;; or SB-EXT:TIMER depending on whether thread support exists. -(defglobal *timer* nil) - -(defun profiled-thread-p (thread) - (let ((profiled-threads *profiled-threads*)) - (if (listp profiled-threads) (memq thread profiled-threads) (neq *timer* thread)))) - -#+(and (or x86 x86-64) (not win32)) -(progn - ;; Ensure that only one thread at a time will be doing profiling stuff. - (defglobal *profiler-lock* (sb-thread:make-mutex :name "Statistical Profiler")) - - (defun sigprof-handler (signal code scp) - (declare (ignore signal code) (optimize speed) - (disable-package-locks sb-di::x86-call-context) - (muffle-conditions compiler-note) - (type system-area-pointer scp)) - (let ((self sb-thread:*current-thread*) - (profiling *profiling*)) - ;; Turn off allocation counter when it is not needed. Doing this in the - ;; signal handler means we don't have to worry about racing with the runtime - (unless (eq :alloc profiling) - (setf sb-vm::*alloc-signal* nil)) - (when (and *sampling* - ;; Normal SIGPROF gets practically speaking delivered to threads - ;; depending on the run time they use, so we need to filter - ;; out those we don't care about. For :ALLOC and :TIME profiling - ;; only the interesting threads get SIGPROF in the first place. - ;; - ;; ...except that Darwin at least doesn't seem to work like we - ;; would want it to, which makes multithreaded :CPU profiling pretty - ;; pointless there -- though it may be that our mach magic is - ;; partially to blame? - (or (not (eq :cpu profiling)) (profiled-thread-p self))) - (with-code-pages-pinned (:dynamic) - (with-system-mutex (*profiler-lock*) - (let ((samples *samples*) - ;; Don't touch the circularity hash-table - *print-circle*) - (when (and samples - (< (samples-trace-count samples) - (samples-max-samples samples))) - (with-alien ((scp (* os-context-t) :local scp)) - (let* ((pc-ptr (sb-vm:context-pc scp)) - (fp (sb-vm::context-register scp - #+x86-64 #.sb-vm::rbp-offset - #+x86 #.sb-vm::ebp-offset))) - ;; foreign code might not have a useful frame - ;; pointer in ebp/rbp, so make sure it looks - ;; reasonable before walking the stack - (unless (sb-di::control-stack-pointer-valid-p (sb-sys:int-sap fp)) - (return-from sigprof-handler nil)) - (incf (samples-trace-count samples)) - (pushnew self (samples-sampled-threads samples)) - (let ((fp (int-sap fp)) - (ok t)) - (declare (type system-area-pointer fp pc-ptr)) - ;; FIXME: How annoying. The XC doesn't store enough - ;; type information about SB-DI::X86-CALL-CONTEXT, - ;; even if we declaim the ftype explicitly in - ;; src/code/debug-int. And for some reason that type - ;; information is needed for the inlined version to - ;; be compiled without boxing the returned saps. So - ;; we declare the correct ftype here manually, even - ;; if the compiler should be able to deduce this - ;; exact same information. - (declare (ftype (function (system-area-pointer) - (values (member nil t) - system-area-pointer - system-area-pointer)) - sb-di::x86-call-context)) - (record-trace-start samples) - (dotimes (i (samples-max-depth samples)) - (record samples pc-ptr) - (setf (values ok pc-ptr fp) - (sb-di::x86-call-context fp)) - (unless ok - ;; If we fail to walk the stack beyond the - ;; initial frame, there is likely something - ;; wrong. Undo the trace start marker and the - ;; one sample we already recorded. - (when (zerop i) - (decf (samples-index samples) - (+ +elements-per-trace-start+ - (* +elements-per-pc-loc+ (1+ i))))) - (return))) - (record-trace-end samples)))) - ;; Reset thread-local allocation counter before interrupts - ;; are enabled. - (when (eq t sb-vm::*alloc-signal*) - (setf sb-vm:*alloc-signal* (1- (samples-alloc-interval samples)))))))))) - nil)) - -;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper -;; than one level. -#-(or x86 x86-64) -(defun sigprof-handler (signal code scp) - (declare (ignore signal code)) - (sb-sys:without-interrupts - (let ((samples *samples*)) - (when (and *sampling* - samples - (< (samples-trace-count samples) - (samples-max-samples samples))) - (sb-sys:without-gcing - (with-alien ((scp (* os-context-t) :local scp)) - (locally (declare (optimize (inhibit-warnings 2))) - (incf (samples-trace-count samples)) - (record-trace-start samples) - (let ((pc-ptr (sb-vm:context-pc scp)) - (fp (sb-vm::context-register scp #.sb-vm::cfp-offset))) - (unless (eq (record samples pc-ptr) :foreign) - (record samples (sap-ref-sap - (int-sap fp) - (* sb-vm::lra-save-offset sb-vm::n-word-bytes))))) - (record-trace-end samples)))))))) - -;;; Return the start address of CODE. -(defun code-start (code) - (declare (type sb-kernel:code-component code)) - (sap-int (sb-kernel:code-instructions code))) - -;;; Return start and end address of CODE as multiple values. -(defun code-bounds (code) - (declare (type sb-kernel:code-component code)) - (let* ((start (code-start code)) - (end (+ start (sb-kernel:%code-text-size code)))) - (values start end))) +(defun sprof-data-header (sap) + (values (sap-ref-sap sap 0) ; bucket pointer + (sap-ref-32 sap 8) ; free pointer + (sap-ref-32 sap 12))) ; capacity +(defconstant n-buckets #x10000) +(defconstant element-size 8) +(defun sprof-data-trace (data trace-index) (sap+ data (* trace-index element-size))) +(defun trace-multiplicity (trace) (sap-ref-32 trace 4)) +(defun trace-len (trace) + #+64-bit (logand (sap-ref-64 trace 8) #xffffffff) + #-64-bit (sap-ref-32 trace 8)) + +;;; Pseudo-functions for marking questionable parts of the stack trace +(defun unavailable-frames ()) +(defun unknown-function ()) + +(defun build-serialno-to-code-map () + ;; Allocate a hash-table for serial# -> code object + ;; Identifying code-containing pages is quick (except on cheneygc), so + ;; two passes over the heap is cheaper than sizing up the table repeatedly. + (let ((ht (make-hash-table + :size (let ((n 0)) + (sb-vm:map-code-objects (lambda (x) (declare (ignore x)) (incf n))) + n)))) + ;; Collect the objects + (sb-vm:map-code-objects + (lambda (x) + (let ((serial (sb-kernel:%code-serialno x))) + (unless (eql serial 0) + (setf (gethash serial ht) x))))) + ht)) + +(defun extract-traces (sap serialno-to-code) + (macrolet ((absolute-pc (pc) + ;; Foreign function or immovable code + `(let ((sap (int-sap ,pc))) + (debug-info sap (sb-di::code-header-from-pc sap)))) + (relative-pc (serialno offset) + ;; Convert serial# + base-address-relative pc-offset + ;; to tagged code object + CODE-INSTRUCTIONS-relative pc-offset. + ;; This can fail only if the code was GCed in the meantime. + `(let* ((id ,serialno) + (code (gethash id serialno-to-code)) + (rel-pc ,offset)) + (when (and (not code) (/= id 0)) + ;; If the serial# could not be found, something has gone wrong in GC. + ;; This really should not happen. If it does, simulate a random code blob + ;; named with that serial#. + (setf code (sb-kernel:fun-code-header + (compile nil `(named-lambda ,(format nil "Unknown fn ~d" id) ()))) + (gethash id serialno-to-code) code + rel-pc 0)) + (if code + (with-pinned-objects (code) + (debug-info (sap+ (int-sap (logandc2 (sb-kernel:get-lisp-obj-address code) + sb-vm:lowtag-mask)) + rel-pc) + code)) + (let ((code (sb-kernel:fun-code-header #'unknown-function))) + (debug-info (sb-kernel:code-instructions code) code))))) + (elision-marker () + `(let ((code (sb-kernel:fun-code-header #'unavailable-frames))) + (debug-info (sb-kernel:code-instructions code) code)))) + (do ((free-ptr (nth-value 1 (sprof-data-header sap))) + (trace-ptr 2) + (result)) + ((>= trace-ptr free-ptr) + (aver (= trace-ptr free-ptr)) + result) + (let* ((trace (sprof-data-trace sap trace-ptr)) + (len (trace-len trace)) + ;; byte offset into the trace at which the locs[] array begins + (element-offset 16) + (locs)) + (dotimes (i len (push (cons (nreverse (coerce locs 'vector)) + (trace-multiplicity trace)) + result)) + (multiple-value-bind (info pc-or-offset) + #-64-bit + (let ((word0 (sap-ref-word trace element-offset)) + (word1 (sap-ref-word trace (+ element-offset 4)))) + (cond ((not (zerop word1)) (relative-pc word0 word1)) ; serial# + offset + ((eql word0 sb-ext:most-positive-word) (elision-marker)) + (t (absolute-pc word0)))) + #+64-bit + (let ((bits (sap-ref-word trace element-offset))) + (cond ((eql bits sb-ext:most-positive-word) (elision-marker)) + ((logbitp 63 bits) + (relative-pc (ldb (byte 32 0) bits) (ldb (byte 31 32) bits))) + (t (absolute-pc bits)))) + (setf locs (list* pc-or-offset info locs)) + (incf element-offset element-size))) + (incf trace-ptr (+ 2 len)))))) + +;;; Call FUNCTION with each thread's sampled data, and deallocate the data. +(defun call-with-each-profile-buffer (function) + (with-alien ((acquire-data (function system-area-pointer unsigned) :extern "acquire_sprof_data")) + (flet ((process (sap thread) + (multiple-value-bind (buckets free-ptr capacity) (sprof-data-header sap) + (let ((buckets-used 0)) + (dotimes (bucket-index n-buckets) + ;; bucket values are uint32_t + (when (plusp (sap-ref-32 buckets (ash bucket-index 2))) (incf buckets-used))) + (funcall function sap thread + (list (* free-ptr element-size) + (* capacity element-size) + buckets-used))) + (sb-sys:deallocate-system-memory buckets (* n-buckets 4)) + (sb-sys:deallocate-system-memory sap (* capacity element-size))))) + (let ((all-threads sb-thread::*all-threads*) + (processed-threads)) + ;; Scan exited threads. Careful not to lose elements if a thread receives a + ;; profiling signal after the timer gets stopped, exits, and pushes data into + ;; the list. i.e. concurrent access to sb-thread::*sprof-data* is possible. + #+sb-thread + (loop + (let ((data (atomic-pop sb-thread::*sprof-data*))) + (unless data (return)) + (destructuring-bind (sap . thread) data + ;; Avoid double-free of the foreign memory, in case two threads try to + ;; reset the profiler at the same time (which constitutes user error) + (when (and sap (eq (cas (car data) sap nil) sap)) + (process sap thread) + (push thread processed-threads))))) + ;; Scan running threads + (sb-thread::avltree-filter + (lambda (node &aux (thread (sb-thread::avlnode-data node))) + (unless (memq thread processed-threads) + ;; Ensure that the thread can't exit (which ensures that it can't free the sprof_sem + ;; that might be needed by the C routine, depending on things), and also ensure + ;; mutual exclusivity with other callers of this. + (sb-thread:with-deathlok (thread c-thread) + (unless (zerop c-thread) + (let ((sap (alien-funcall acquire-data c-thread))) + (unless (= (sap-int sap) 0) + (process sap thread)))))) + nil) + all-threads))))) + +(defun convert-raw-data () + (let ((ht (build-serialno-to-code-map)) + (threads) + ;; traces are not de-deduplicated across threads, + ;; so this number is only approximate. + (n-unique-traces 0) + (aggregate-data)) + ;; Mask SIGPROF in this thread in case of pending signal + ;; and funky scheduling by the OS. + (let ((saved-sigprof-mask (sb-toggle-sigprof (int-sap 0) 1))) + (call-with-each-profile-buffer + (lambda (sap thread memusage) + (push (cons thread memusage) threads) + (push (cons (extract-traces sap ht) thread) aggregate-data))) + (setf (extern-alien "sb_sprof_enabled" int) 0) + (sb-toggle-sigprof (int-sap 0) saved-sigprof-mask)) + ;; Precompute the length of the new SAMPLES-VECTOR + (let ((vector + (make-array + (let ((total-length 0)) + (dolist (subsample aggregate-data total-length) + (loop for (trace . multiplicity) in (car subsample) + do (incf total-length (* (+ (length trace) +elements-per-trace-start+) + multiplicity))))))) + (index 0)) + ;; Now fill in the vector to match the old data format. + ;; This is of needlessly inefficient for :ALLOC mode, since the entire point + ;; of the new format is to speed up callgraph construction. + (dolist (subsample aggregate-data) + (loop with thread = (cdr subsample) + for (trace . multiplicity) in (car subsample) + do (incf n-unique-traces) + (dotimes (i multiplicity) + (let* ((len (+ (length trace) +elements-per-trace-start+)) + (end (+ index len))) + (setf (aref vector index) `(trace-start . ,end) + (aref vector (1+ index)) thread) + (replace vector trace :start1 (+ index 2)) + (setq index end))))) + (aver (= index (length vector))) + (values vector n-unique-traces threads)))) + +#+nil +(defun dump-hash-buckets (sap-or-thread) + (binding* ((sap (if (typep sap-or-thread 'sb-thread::thread) + (sap-ref-sap (int-sap (sb-thread::thread-primitive-thread sap-or-thread)) + (ash sb-vm:thread-sprof-data-slot sb-vm:word-shift)) + sap-or-thread)) + ((buckets free-ptr) (sprof-data-header sap)) + (buckets-used 0) + (trace-ptr 2) + (n-traces 0) + (n-unique 0)) + (dotimes (bucket-index n-buckets) + (let ((n (do ((entry (sap-ref-32 buckets (ash bucket-index 2)) + (sap-ref-32 (sprof-data-trace sap entry) 0)) + (chainlen 0 (1+ chainlen))) + ((= entry 0) chainlen)))) + (when (plusp n) + (incf buckets-used) + (format t "~5d ~d~%" bucket-index n)))) + (loop while (< trace-ptr free-ptr) + do (let ((trace (sprof-data-trace sap trace-ptr))) + (incf n-unique) + (incf n-traces (trace-multiplicity trace)) + (incf trace-ptr (+ 2 (trace-len trace))))) + (aver (= trace-ptr free-ptr)) + (format t "~d buckets in use, ~D unique traces, ~D total~%" buckets-used n-unique n-traces))) + +#+nil +(defun code-summary-by-gc-generation () + (let ((gens (make-array 7 :initial-element 0))) + (dolist (code (sb-vm:list-allocated-objects :all :type sb-vm:code-header-widetag)) + (let ((gen (sb-kernel:generation-of code))) + (when (<= 0 gen 6) + (incf (aref gens gen))))) + gens)) diff -Nru sbcl-2.1.1/contrib/sb-sprof/report.lisp sbcl-2.1.11/contrib/sb-sprof/report.lisp --- sbcl-2.1.1/contrib/sb-sprof/report.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/report.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -38,27 +38,28 @@ count (scc-p v)))) (if (eq (call-graph-sampling-mode call-graph) :alloc) (format t "~2&Number of samples: ~d~%~ + Unique traces: ~d~%~ Alloc interval: ~a regions (approximately ~a kB)~%~ - Total sampling amount: ~a regions (approximately ~a kB)~%~ - Number of cycles: ~d~%~ - Sampled threads:~{~% ~S~}~2%" + Total sampling amount: ~a regions (approximately ~a kB)" nsamples + (call-graph-unique-trace-count call-graph) interval (truncate (* interval +alloc-region-size+) 1024) (* nsamples interval) - (truncate (* nsamples interval +alloc-region-size+) 1024) - ncycles - (call-graph-sampled-threads call-graph)) + (truncate (* nsamples interval +alloc-region-size+) 1024)) (format t "~2&Number of samples: ~d~%~ Sample interval: ~f seconds~%~ - Total sampling time: ~f seconds~%~ - Number of cycles: ~d~%~ - Sampled threads:~{~% ~S~}~2%" + Total sampling time: ~f seconds" nsamples interval - (* nsamples interval) - ncycles - (call-graph-sampled-threads call-graph))))) + (* nsamples interval))) + (format t "~%Graph cycles: ~d~%~ + Sampled threads:~%" ncycles) + (loop for (thread bytes-used bytes-reserved buckets-used) + in (call-graph-sampled-threads call-graph) + do (format t " ~a (~d/~d bytes, ~d hash buckets)~%" + thread bytes-used bytes-reserved buckets-used)) + (terpri))) (declaim (type report-sort-key *report-sort-by*)) (defvar *report-sort-by* :samples @@ -260,8 +261,8 @@ calling RESET.) Profiling is stopped before the call graph is generated." - (cond (*samples* - (let ((graph (or call-graph (make-call-graph most-positive-fixnum)))) + (acond (*samples* + (let ((graph (or call-graph (make-call-graph it most-positive-fixnum)))) (ecase type (:flat (print-flat graph :stream stream :max max :min-percent min-percent)) @@ -269,6 +270,6 @@ (print-graph graph :stream stream :max max :min-percent min-percent)) ((nil))) graph)) - (t - (format stream "~&; No samples to report.~%") - nil))) + (t + (format stream "~&; No samples to report.~%") + nil))) diff -Nru sbcl-2.1.1/contrib/sb-sprof/sb-sprof.asd sbcl-2.1.11/contrib/sb-sprof/sb-sprof.asd --- sbcl-2.1.1/contrib/sb-sprof/sb-sprof.asd 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/sb-sprof.asd 2021-11-30 16:16:46.000000000 +0000 @@ -20,6 +20,6 @@ :depends-on ("sb-sprof") :components ((:file "test")) :perform (test-op (o c) - #-(or win32 darwin) ;not yet + #-(or win32) ;not yet (or (funcall (find-symbol "RUN-TESTS" "SB-SPROF-TEST")) (error "test-op failed")))) diff -Nru sbcl-2.1.1/contrib/sb-sprof/sb-sprof.texinfo sbcl-2.1.11/contrib/sb-sprof/sb-sprof.texinfo --- sbcl-2.1.1/contrib/sb-sprof/sb-sprof.texinfo 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/sb-sprof.texinfo 2021-11-30 16:16:46.000000000 +0000 @@ -131,10 +131,6 @@ @include fun-sb-sprof-map-traces.texinfo -@include fun-sb-sprof-map-trace-samples.texinfo - -@include fun-sb-sprof-map-all-samples.texinfo - @include fun-sb-sprof-sample-pc.texinfo @include fun-sb-sprof-report.texinfo diff -Nru sbcl-2.1.1/contrib/sb-sprof/test.lisp sbcl-2.1.11/contrib/sb-sprof/test.lisp --- sbcl-2.1.1/contrib/sb-sprof/test.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/contrib/sb-sprof/test.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -6,17 +6,6 @@ ;#+sb-fasteval (setq sb-ext:*evaluator-mode* :compile) -;;; SIGPROF-HANDLER used to have a slow call to ALIEN-FUNCALL which entails -;;; COMPILE which entails needing to acquire *WORLD-LOCK* for various things. -;;; It was the mother of all deadlocks. -#-win32 -(let ((c (sb-kernel:fun-code-header #'sb-sprof::sigprof-handler))) - (loop for i from sb-vm:code-constants-offset below (sb-kernel:code-header-words c) - do (let ((obj (sb-kernel:code-header-ref c i))) - (if (typep obj 'sb-kernel:fdefn) - (assert (not (eq (sb-kernel:fdefn-name obj) - 'sb-alien:alien-funcall))))))) - ;;; silly examples (defun test-0 (n &optional (depth 0)) @@ -54,13 +43,52 @@ while (< (get-universal-time) target) do (consalot)))) +;; This has been failing on Sparc/SunOS for a while, +;; having nothing to do with the rewrite of sprof's +;; data collector into C. Maybe it works on Linux +;; but the less fuss about Sparc, the better. +#+sparc (defun run-tests () t) + +(defvar *compiler-input* "graph") +(defvar *compiler-output* "./foo.fasl") +(defvar *sprof-loop-test-max-samples* 50) + +#-sparc (defun run-tests () + (proclaim '(sb-ext:muffle-conditions style-warning)) + (sb-sprof:with-profiling (:max-samples *sprof-loop-test-max-samples* + :report :flat :loop t :show-progress t) + ;; Notice that "./foo.fasl" writes into this directory, whereas simply "foo.fasl" + ;; would write into "../../src/code/" + ;; Notice also that our file I/O routines are so crappy that 15% of the test + ;; is spent in lseek, and 12% in write. Just wow! + ;; Self Total Cumul + ;; Nr Count % Count % Count % Calls Function + ;; ------------------------------------------------------------------------ + ;; 1 15 15.0 15 15.0 15 15.0 - foreign function __lseek + ;; 2 12 12.0 12 12.0 27 27.0 - foreign function write + ;; 3 7 7.0 7 7.0 34 34.0 - foreign function __pthread_sigmask + + ;; + (compile-file *compiler-input* :output-file *compiler-output* :print nil)) + (delete-file *compiler-output*) (let ((*standard-output* (make-broadcast-stream))) (test) - (consing-test))) - -;; For debugging purposes, print output for visual inspection to see if -;; the allocation sequence gets hit in the right places (i.e. not at all -;; in traditional builds, and everywhere if SB-SAFEPOINT-STRICTLY is -;; enabled.) -#+nil (disassemble #'consalot) + (consing-test) + ;; This test shows that STOP-SAMPLING and START-SAMPLING on a thread do something. + ;; Based on rev b6bf65d9 it would seem that the API got broken a little. + ;; The thread doesn't do a whole lot, which is fine for what it is. + #+sb-thread + (let* ((sem (sb-thread:make-semaphore)) + (some-thread (sb-thread:make-thread #'sb-thread:wait-on-semaphore :arguments sem + :name "donothing"))) + (sb-sprof:stop-sampling some-thread) + (sb-sprof:start-sampling some-thread) + (sb-thread:signal-semaphore sem) + ;; Join because when run by run-tests.sh, it's an error to have random leftover threads + (sb-thread:join-thread some-thread)) + ;; For debugging purposes, print output for visual inspection to see where + ;; the allocation sequence gets hit. + ;; It can be interrupted even inside pseudo-atomic now. + (disassemble #'consalot :stream *error-output*)) + t) diff -Nru sbcl-2.1.1/crossbuild-runner/backends/arm64/features sbcl-2.1.11/crossbuild-runner/backends/arm64/features --- sbcl-2.1.1/crossbuild-runner/backends/arm64/features 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/arm64/features 2021-11-30 16:16:46.000000000 +0000 @@ -2,3 +2,6 @@ :alien-callbacks :unbind-in-unwind :compare-and-swap-vops :undefined-fun-restarts +:unwind-to-frame-and-call-vop +:call-symbol +:no-continue-unwind diff -Nru sbcl-2.1.1/crossbuild-runner/backends/hppa/features sbcl-2.1.11/crossbuild-runner/backends/hppa/features --- sbcl-2.1.1/crossbuild-runner/backends/hppa/features 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/hppa/features 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -:cheneygc diff -Nru sbcl-2.1.1/crossbuild-runner/backends/hppa/local-target-features sbcl-2.1.11/crossbuild-runner/backends/hppa/local-target-features --- sbcl-2.1.1/crossbuild-runner/backends/hppa/local-target-features 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/hppa/local-target-features 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -:cheneygc :big-endian diff -Nru sbcl-2.1.1/crossbuild-runner/backends/hppa/stuff-groveled-from-headers.lisp sbcl-2.1.11/crossbuild-runner/backends/hppa/stuff-groveled-from-headers.lisp --- sbcl-2.1.1/crossbuild-runner/backends/hppa/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/hppa/stuff-groveled-from-headers.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,146 +0,0 @@ -;;;; This is an automatically generated file, please do not hand-edit it. -;;;; See the program "grovel-headers.c". - -(in-package "SB-ALIEN") - -;;;flags for dlopen() -(defconstant rtld-lazy 1) ; #x1 -(defconstant rtld-now 2) ; #x2 -(defconstant rtld-global 4) ; #x4 -(in-package "SB-UNIX") - -;;; select() -(defconstant fd-setsize 1024) ; #x400 -;;; poll() -(defconstant pollin 1) ; #x1 -(defconstant pollout 4) ; #x4 -(defconstant pollpri 2) ; #x2 -(defconstant pollhup 16) ; #x10 -(defconstant pollnval 32) ; #x20 -(defconstant pollerr 8) ; #x8 -(define-alien-type nfds-t (unsigned 32)) -;;; langinfo -(defconstant codeset 14) ; #xe -;;; types, types, types -(define-alien-type clock-t (signed 32)) -(define-alien-type dev-t (unsigned 64)) -(define-alien-type gid-t (unsigned 32)) -(define-alien-type ino-t (unsigned 64)) -(define-alien-type mode-t (unsigned 32)) -(define-alien-type nlink-t (unsigned 32)) -(define-alien-type off-t (signed 64)) -(define-alien-type size-t (unsigned 32)) -(define-alien-type time-t (signed 32)) -(define-alien-type suseconds-t (signed 32)) -(define-alien-type uid-t (unsigned 32)) -;; Types in src/runtime/wrap.h. See that file for explantion. -;; Don't use these types for anything other than the stat wrapper. -(define-alien-type wst-ino-t (unsigned 64)) -(define-alien-type wst-dev-t (unsigned 32)) -(define-alien-type wst-off-t (signed 64)) -(define-alien-type wst-blksize-t (signed 32)) -(define-alien-type wst-blkcnt-t (signed 64)) -(define-alien-type wst-nlink-t (unsigned 32)) -(define-alien-type wst-uid-t (unsigned 32)) -(define-alien-type wst-gid-t (unsigned 32)) - -;;; fcntl.h (or unistd.h on OpenBSD and NetBSD) -(defconstant r_ok 4) ; #x4 -(defconstant w_ok 2) ; #x2 -(defconstant x_ok 1) ; #x1 -(defconstant f_ok 0) ; #x0 - -;;; fcntlbits.h -(defconstant o_rdonly 0) ; #x0 -(defconstant o_wronly 1) ; #x1 -(defconstant o_rdwr 2) ; #x2 -(defconstant o_accmode 3) ; #x3 -(defconstant o_creat 256) ; #x100 -(defconstant o_excl 1024) ; #x400 -(defconstant o_noctty 2048) ; #x800 -(defconstant o_trunc 512) ; #x200 -(defconstant o_append 8) ; #x8 -(defconstant o_largefile 8192) ; #x2000 -;;; -(defconstant s-ifmt 61440) ; #xf000 -(defconstant s-ififo 4096) ; #x1000 -(defconstant s-ifchr 8192) ; #x2000 -(defconstant s-ifdir 16384) ; #x4000 -(defconstant s-ifblk 24576) ; #x6000 -(defconstant s-ifreg 32768) ; #x8000 - -(defconstant s-iflnk 40960) ; #xa000 -(defconstant s-ifsock 49152) ; #xc000 - -;;; error numbers -(defconstant ebadf 9) ; #x9 -(defconstant enoent 2) ; #x2 -(defconstant eintr 4) ; #x4 -(defconstant eagain 11) ; #xb -(defconstant eio 5) ; #x5 -(defconstant eexist 17) ; #x11 -(defconstant eloop 90) ; #x5a -(defconstant espipe 29) ; #x1d -(defconstant epipe 32) ; #x20 -(defconstant ewouldblock 11) ; #xb - -;;; for waitpid() in run-program.lisp -(defconstant wnohang 1) ; #x1 -(defconstant wuntraced 2) ; #x2 - -;;; various ioctl(2) flags -(defconstant tiocgpgrp 1074033783) ; #x40047477 - -;;; signals -(defconstant sigalrm 14) ; #xe -(defconstant sigbus 10) ; #xa -(defconstant sigchld 18) ; #x12 -(defconstant sigcont 25) ; #x19 -(defconstant sigemt 7) ; #x7 -(defconstant sigfpe 8) ; #x8 -(defconstant sighup 1) ; #x1 -(defconstant sigill 4) ; #x4 -(defconstant sigint 2) ; #x2 -(defconstant sigio 22) ; #x16 -(defconstant sigkill 9) ; #x9 -(defconstant sigpipe 13) ; #xd -(defconstant sigprof 29) ; #x1d -(defconstant sigquit 3) ; #x3 -(defconstant sigsegv 11) ; #xb -(defconstant sigstop 23) ; #x17 -(defconstant sigsys 12) ; #xc -(defconstant sigterm 15) ; #xf -(defconstant sigtrap 5) ; #x5 -(defconstant sigtstp 24) ; #x18 -(defconstant sigttin 26) ; #x1a -(defconstant sigttou 27) ; #x1b -(defconstant sigurg 21) ; #x15 -(defconstant sigusr1 16) ; #x10 -(defconstant sigusr2 17) ; #x11 -(defconstant sigvtalrm 28) ; #x1c -(defconstant sigwinch 20) ; #x14 -(defconstant sigxcpu 30) ; #x1e -(defconstant sigxfsz 31) ; #x1f -(defconstant fpe-intovf 2) ; #x2 -(defconstant fpe-intdiv 1) ; #x1 -(defconstant fpe-fltdiv 3) ; #x3 -(defconstant fpe-fltovf 4) ; #x4 -(defconstant fpe-fltund 5) ; #x5 -(defconstant fpe-fltres 6) ; #x6 -(defconstant fpe-fltinv 7) ; #x7 -(defconstant fpe-fltsub 8) ; #x8 - -;;; structures -(define-alien-type nil - (struct timeval - (tv-sec (signed 32)) - (tv-usec (signed 32)))) -(define-alien-type nil - (struct timespec - (tv-sec (signed 32)) - (tv-nsec (signed 32)))) - -(in-package "SB-KERNEL") - -;;; Our runtime types -(define-alien-type os-vm-size-t (unsigned 32)) diff -Nru sbcl-2.1.1/crossbuild-runner/backends/mips/stuff-groveled-from-headers.lisp sbcl-2.1.11/crossbuild-runner/backends/mips/stuff-groveled-from-headers.lisp --- sbcl-2.1.1/crossbuild-runner/backends/mips/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/mips/stuff-groveled-from-headers.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -7,6 +7,7 @@ (defconstant rtld-lazy 1) ; #x1 (defconstant rtld-now 2) ; #x2 (defconstant rtld-global 4) ; #x4 + (in-package "SB-UNIX") ;;; select() @@ -19,8 +20,6 @@ (defconstant pollnval 32) ; #x20 (defconstant pollerr 8) ; #x8 (define-alien-type nfds-t (unsigned 32)) -;;; langinfo -(defconstant codeset 14) ; #xe ;;; types, types, types (define-alien-type clock-t (signed 32)) (define-alien-type dev-t (unsigned 64)) @@ -30,6 +29,7 @@ (define-alien-type nlink-t (unsigned 32)) (define-alien-type off-t (signed 64)) (define-alien-type size-t (unsigned 32)) +(define-alien-type ssize-t (signed 32)) (define-alien-type time-t (signed 32)) (define-alien-type suseconds-t (signed 32)) (define-alien-type uid-t (unsigned 32)) @@ -80,11 +80,13 @@ (defconstant eio 5) ; #x5 (defconstant eexist 17) ; #x11 (defconstant eloop 90) ; #x5a -(defconstant espipe 29) ; #x1d (defconstant epipe 32) ; #x20 +(defconstant espipe 29) ; #x1d (defconstant ewouldblock 11) ; #xb +(defconstant sc-nprocessors-onln 84) ; #x54 ;;; for waitpid() in run-program.lisp +(defconstant wcontinued 8) ; #x8 (defconstant wnohang 1) ; #x1 (defconstant wuntraced 2) ; #x2 @@ -92,6 +94,10 @@ (defconstant tiocgpgrp 1074033783) ; #x40047477 ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_block 1) ; #x1 +(defconstant sig_unblock 2) ; #x2 +(defconstant sig_setmask 3) ; #x3 (defconstant sigalrm 14) ; #xe (defconstant sigbus 10) ; #xa (defconstant sigchld 18) ; #x12 @@ -130,6 +136,13 @@ (defconstant fpe-fltinv 7) ; #x7 (defconstant fpe-fltsub 8) ; #x8 +(defconstant clock-realtime 0) ; #x0 +(defconstant clock-monotonic 1) ; #x1 +(defconstant clock-process-cputime-id 2) ; #x2 +(defconstant clock-realtime-coarse 5) ; #x5 +(defconstant clock-monotonic-coarse 6) ; #x6 +(defconstant clock-monotonic-raw 4) ; #x4 +(defconstant clock-thread-cputime-id 3) ; #x3 ;;; structures (define-alien-type nil (struct timeval diff -Nru sbcl-2.1.1/crossbuild-runner/backends/ppc64/features sbcl-2.1.11/crossbuild-runner/backends/ppc64/features --- sbcl-2.1.1/crossbuild-runner/backends/ppc64/features 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/ppc64/features 2021-11-30 16:16:46.000000000 +0000 @@ -1,5 +1,5 @@ ; threads are required because differing versions of the vops for BOUNDP ; and [fast-]symbol-[global-]value and CAS create extra maintenance burden. -:64-bit :untagged-fdefns :sb-thread +:64-bit :untagged-fdefns :sb-thread :soft-card-marks :gencgc :compare-and-swap-vops :alien-callbacks diff -Nru sbcl-2.1.1/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp sbcl-2.1.11/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp --- sbcl-2.1.1/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/sparc/stuff-groveled-from-headers.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -91,6 +91,9 @@ (defconstant tiocgpgrp 1074033795) ; #x40047483 ;;; signals +(defconstant sizeof-sigset_t 128) ; #x80 +(defconstant sig_setmask 2) ; #x2 +(defconstant sig_unblock 2) ; #x2 (defconstant sigalrm 14) ; #xe (defconstant sigbus 10) ; #xa (defconstant sigchld 20) ; #x14 @@ -129,6 +132,9 @@ (defconstant fpe-fltinv 7) ; #x7 (defconstant fpe-fltsub 8) ; #x8 +(defconstant clock-process-cputime-id 2) ; #x2 +(defconstant clock-monotonic-coarse 6) ; #x6 + ;;; structures (define-alien-type nil (struct timeval @@ -147,3 +153,4 @@ ;;; Our runtime types (define-alien-type os-vm-size-t (unsigned 32)) + diff -Nru sbcl-2.1.1/crossbuild-runner/backends/x86-64/features sbcl-2.1.11/crossbuild-runner/backends/x86-64/features --- sbcl-2.1.1/crossbuild-runner/backends/x86-64/features 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/x86-64/features 2021-11-30 16:16:46.000000000 +0000 @@ -1,5 +1,6 @@ :64-bit :gencgc +:soft-card-marks :stack-grows-downward-not-upward :c-stack-is-control-stack :compare-and-swap-vops diff -Nru sbcl-2.1.1/crossbuild-runner/backends/x86-64/stuff-groveled-from-headers.lisp sbcl-2.1.11/crossbuild-runner/backends/x86-64/stuff-groveled-from-headers.lisp --- sbcl-2.1.1/crossbuild-runner/backends/x86-64/stuff-groveled-from-headers.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/backends/x86-64/stuff-groveled-from-headers.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,6 +14,7 @@ (defconstant max_path 1024) (defconstant error-no-data 1) (defconstant +exception-maximum-parameters+ 6) +(defconstant +exception-heap-corruption+ #xdeadbeef) ; random (in-package "SB-ALIEN") diff -Nru sbcl-2.1.1/crossbuild-runner/build-all.sh sbcl-2.1.11/crossbuild-runner/build-all.sh --- sbcl-2.1.1/crossbuild-runner/build-all.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/build-all.sh 2021-11-30 16:16:46.000000000 +0000 @@ -22,17 +22,16 @@ # to this cross-build test. Some of the provisions are only for C code which # we don't compile. Or else it doesn't matter much which lisp code is compiled. # Assume that dlopen() is provided so that we don't try to read sbcl.nm though. - echo '(lambda (features) (union features (list :crossbuild-test :os-provides-dlopen ' > $ltf + echo '(lambda (features) (union features (list :os-provides-dlopen ' > $ltf echo ":$arch" >> $ltf # x86 and x86-64 are tested as if #+win32. Unix is otherwise plenty tested. if [ $arch = x86 -o $arch = x86-64 ]; then - echo ':win32 :sb-thread :sb-safepoint :sb-thruption :sb-wtimer' >> $ltf + echo ':win32 :sb-thread :sb-safepoint' >> $ltf else echo ':unix :linux :elf' >> $ltf fi cat crossbuild-runner/backends/$arch/features >> $ltf cat crossbuild-runner/backends/$arch/local-target-features >> $ltf - echo ':linkage-table' >> $ltf echo ')))' >> $ltf cp -fv crossbuild-runner/backends/$arch/stuff-groveled-from-headers.lisp \ diff -Nru sbcl-2.1.1/crossbuild-runner/Makefile sbcl-2.1.11/crossbuild-runner/Makefile --- sbcl-2.1.1/crossbuild-runner/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/Makefile 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,53 @@ +all: output/arm.core output/arm64.core output/mips.core output/ppc.core output/ppc64.core \ + output/riscv.core output/sparc.core output/x86.core output/x86-64.core + +SBCL=src/runtime/sbcl +ARGS=--core output/sbcl.core --noinform --disable-debugger --noprint --no-userinit --no-sysinit +SCRIPT1=crossbuild-runner/pass-1.lisp +SCRIPT2=crossbuild-runner/pass-2.lisp +DEPS1=crossbuild-runner/pass-1.lisp src/cold/build-order.lisp-expr # FIXME: and all the sources, of course + +obj/xbuild/arm/xc.core: $(DEPS1) + $(SBCL) $(ARGS) arm < $(SCRIPT1) +output/arm.core: obj/xbuild/arm/xc.core + $(SBCL) $(ARGS) arm < $(SCRIPT2) + +obj/xbuild/arm64/xc.core: $(DEPS1) + $(SBCL) $(ARGS) arm64 < $(SCRIPT1) +output/arm64.core: obj/xbuild/arm64/xc.core + $(SBCL) $(ARGS) arm64 < $(SCRIPT2) + +obj/xbuild/mips/xc.core: $(DEPS1) + $(SBCL) $(ARGS) mips < $(SCRIPT1) +output/mips.core: obj/xbuild/mips/xc.core + $(SBCL) $(ARGS) mips < $(SCRIPT2) + +obj/xbuild/ppc/xc.core: $(DEPS1) + $(SBCL) $(ARGS) ppc < $(SCRIPT1) +output/ppc.core: obj/xbuild/ppc/xc.core + $(SBCL) $(ARGS) ppc < $(SCRIPT2) + +obj/xbuild/ppc64/xc.core: $(DEPS1) + $(SBCL) $(ARGS) ppc64 < $(SCRIPT1) +output/ppc64.core: obj/xbuild/ppc64/xc.core + $(SBCL) $(ARGS) ppc64 < $(SCRIPT2) + +obj/xbuild/riscv/xc.core: $(DEPS1) + $(SBCL) $(ARGS) riscv < $(SCRIPT1) +output/riscv.core: obj/xbuild/riscv/xc.core + $(SBCL) $(ARGS) riscv < $(SCRIPT2) + +obj/xbuild/sparc/xc.core: $(DEPS1) + $(SBCL) $(ARGS) sparc < $(SCRIPT1) +output/sparc.core: obj/xbuild/sparc/xc.core + $(SBCL) $(ARGS) sparc < $(SCRIPT2) + +obj/xbuild/x86/xc.core: $(DEPS1) + $(SBCL) $(ARGS) x86 < $(SCRIPT1) +output/x86.core: obj/xbuild/x86/xc.core + $(SBCL) $(ARGS) x86 < $(SCRIPT2) + +obj/xbuild/x86-64/xc.core: $(DEPS1) + $(SBCL) $(ARGS) x86-64 < $(SCRIPT1) +output/x86-64.core: obj/xbuild/x86-64/xc.core + $(SBCL) $(ARGS) x86-64 < $(SCRIPT2) diff -Nru sbcl-2.1.1/crossbuild-runner/pass-1.lisp sbcl-2.1.11/crossbuild-runner/pass-1.lisp --- sbcl-2.1.1/crossbuild-runner/pass-1.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/pass-1.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,33 @@ +;; (setq *default-pathname-defaults* #p"") ; FIXME: causes redefinition warnings! +(let* ((target-name (second sb-ext:*posix-argv*)) + (build-dir (format nil "obj/xbuild/~A/" target-name)) + (ltf (format nil "~A/local-target-features" build-dir)) + (objroot (format nil "~A/from-host/" build-dir))) + (ensure-directories-exist objroot) + (defvar *sbcl-host-obj-prefix* objroot) + (setq sb-sys:*stdout* (open (format nil "~A/stdout" objroot) :direction :output + :if-does-not-exist :create :if-exists :supersede) + sb-sys:*stderr* (open (format nil "~A/stderr" objroot) :direction :output + :if-does-not-exist :create :if-exists :supersede)) + (defvar *sbcl-local-target-features-file* ltf) + (with-open-file (*standard-output* ltf :direction :output + :if-does-not-exist :create + :if-exists :supersede) + (let ((target-symbol (intern (string-upcase target-name) "KEYWORD"))) + (format t "(lambda (features) (union features (list :crossbuild-test :os-provides-dlopen ~s ~a~%" + target-symbol + (case target-symbol + ((:x86 :x86-64) ":win32 :sb-thread :sb-safepoint") + (t ":unix :linux :elf")))) + ;; "features" contains the mandatory set of symbols for any build of that target. + (dolist (features-filename '("features" "local-target-features")) + (with-open-file (f (format nil "crossbuild-runner/backends/~a/~a" + target-name features-filename)) + (let ((string (make-string (file-length f)))) + (read-sequence string f) + (write-string string)))) + (format t ")))~%")) + (load "make-host-1.lisp") + (finish-output sb-sys:*stdout*) + (finish-output sb-sys:*stderr*) + (save-lisp-and-die (format nil "~A/xc.core" build-dir))) diff -Nru sbcl-2.1.1/crossbuild-runner/pass-2.lisp sbcl-2.1.11/crossbuild-runner/pass-2.lisp --- sbcl-2.1.1/crossbuild-runner/pass-2.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/crossbuild-runner/pass-2.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,35 @@ +(defvar *sbcl-local-target-features-file* + (format nil "obj/xbuild/~A/local-target-features" (second sb-ext:*posix-argv*))) +(load "src/cold/shared.lisp") +(in-package "SB-COLD") +(let* ((target-name (second sb-ext:*posix-argv*)) + (build-dir (format nil "obj/xbuild/~A/" target-name)) + (objroot (format nil "~A/from-xc/" build-dir))) + (ensure-directories-exist objroot) + (defvar *host-obj-prefix* (format nil "~A/from-host/" build-dir)) + (defvar *target-obj-prefix* objroot) + (setq sb-sys:*stdout* (open (format nil "~A/stdout" objroot) :direction :output + :if-does-not-exist :create :if-exists :supersede) + sb-sys:*stderr* (open (format nil "~A/stderr" objroot) :direction :output + :if-does-not-exist :create :if-exists :supersede))) +(load "src/cold/set-up-cold-packages.lisp") +(load "src/cold/defun-load-or-cload-xcompiler.lisp") +(load-or-cload-xcompiler #'host-load-stem) + +;;; Redefine STEM-SOURCE-PATH to take 'stuff-groveled-from-headers' from the +;;; architecture-dependent location, but otherwise the normal location. +(host-sb-int:encapsulate 'stem-source-path 'wrap + (lambda (realfun stem) + (if (string= stem "output/stuff-groveled-from-headers") + (format nil "crossbuild-runner/backends/~a/stuff-groveled-from-headers.lisp" + (string-downcase (sb-cold::target-platform-keyword))) + (funcall realfun stem)))) + +(format t "~&Target features: ~S~%" sb-xc:*features*) +(let ((warnings (sb-xc:with-compilation-unit () + (load "src/cold/compile-cold-sbcl.lisp") + sb-c::*undefined-warnings*))) + (finish-output host-sb-sys:*stdout*) + (finish-output host-sb-sys:*stderr*) + (when (and warnings (not (target-featurep :win32))) + (error "Fail"))) diff -Nru sbcl-2.1.1/debian/changelog sbcl-2.1.11/debian/changelog --- sbcl-2.1.1/debian/changelog 2021-02-03 20:37:00.000000000 +0000 +++ sbcl-2.1.11/debian/changelog 2021-12-01 10:44:18.000000000 +0000 @@ -1,3 +1,47 @@ +sbcl (2:2.1.11-1) unstable; urgency=medium + + * New upstream release + * vop-existsp-test.patch: new patch, fixes test failure + + -- Sébastien Villemot Wed, 01 Dec 2021 11:44:18 +0100 + +sbcl (2:2.1.10-1) unstable; urgency=medium + + * New upstream release + + -- Sébastien Villemot Tue, 02 Nov 2021 11:22:02 +0100 + +sbcl (2:2.1.9-1) unstable; urgency=medium + + * New upstream release + * Use clisp on s390x for bootstrapping, since it now builds there + + -- Sébastien Villemot Tue, 28 Sep 2021 12:24:26 +0200 + +sbcl (2:2.1.8-1) unstable; urgency=medium + + * New upstream release + * Add Breaks against cl-nibbles << 20210520.gitdad2524-1~, needed for amd64 + + -- Sébastien Villemot Mon, 30 Aug 2021 20:26:50 +0200 + +sbcl (2:2.1.7-1) unstable; urgency=medium + + * New upstream release + * skip-stack-scan-precise-gencgc.patch: drop patch, applied upstream + * Bump S-V to 4.6.0 + * On riscv64, s390x and sh4, try to bootstrap with ecl (since clisp is + not available there) + * fix-chill-test.patch: new patch, fixes chill.test.sh in the Debian-specific + context + * Remove unused lintian override (hardening-no-pie) + * Add more fields to d/upstream/metadata + * sbcl.{postinst,prerm}: replace “which” by “command -v” + * skip-some-autopkgtests.patch: also skip run-sbcl.test.sh, since it does not + make sense in an autopkgtest context + + -- Sébastien Villemot Wed, 25 Aug 2021 12:09:46 +0200 + sbcl (2:2.1.1-2) unstable; urgency=medium * skip-stack-scan-precise-gencgc.patch: new patch from upstream, fixes diff -Nru sbcl-2.1.1/debian/control sbcl-2.1.11/debian/control --- sbcl-2.1.1/debian/control 2020-11-29 20:27:04.000000000 +0000 +++ sbcl-2.1.11/debian/control 2021-09-05 14:56:25.000000000 +0000 @@ -7,7 +7,9 @@ Priority: optional Build-Depends: debhelper-compat (= 13), debhelper (>= 12.8~), - clisp [!amd64 !arm64 !armel !armhf !i386 !kfreebsd-amd64 !powerpc !ppc64 !ppc64el], +# Arch list to keep in sync with debian/rules + clisp [!amd64 !arm64 !armel !armhf !i386 !kfreebsd-amd64 !powerpc !ppc64 !ppc64el !riscv64 !sh4], + ecl [riscv64 sh4], sbcl [amd64 arm64 armel armhf i386 kfreebsd-amd64 powerpc ppc64 ppc64el], sbcl-source, texinfo, @@ -23,7 +25,7 @@ netbase, ed, strace [!kfreebsd-amd64 !kfreebsd-i386] -Standards-Version: 4.5.1 +Standards-Version: 4.6.0 Vcs-Browser: https://salsa.debian.org/common-lisp-team/sbcl Vcs-Git: https://salsa.debian.org/common-lisp-team/sbcl.git Homepage: http://www.sbcl.org @@ -38,7 +40,8 @@ sbcl-source, slime Breaks: cl-asdf (<< 2:3.3.3-4~), - cl-cffi (<< 1:0.22.1-1~) + cl-cffi (<< 1:0.22.1-1~), + cl-nibbles (<< 20210520.gitdad2524-1~) Provides: lisp-compiler, ${sbcl:fasl-version} Description: Common Lisp compiler and development system diff -Nru sbcl-2.1.1/debian/patches/disable-timer-test.patch sbcl-2.1.11/debian/patches/disable-timer-test.patch --- sbcl-2.1.1/debian/patches/disable-timer-test.patch 2020-09-22 12:37:29.000000000 +0000 +++ sbcl-2.1.11/debian/patches/disable-timer-test.patch 2021-08-24 18:58:09.000000000 +0000 @@ -9,7 +9,7 @@ This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ --- a/tests/timer.impure.lisp +++ b/tests/timer.impure.lisp -@@ -282,7 +282,7 @@ +@@ -271,7 +271,7 @@ (with-test (:name (:timer :threaded-stress) :skipped-on (not :sb-thread) diff -Nru sbcl-2.1.1/debian/patches/fix-chill-test.patch sbcl-2.1.11/debian/patches/fix-chill-test.patch --- sbcl-2.1.1/debian/patches/fix-chill-test.patch 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/debian/patches/fix-chill-test.patch 2021-08-25 09:13:01.000000000 +0000 @@ -0,0 +1,26 @@ +Description: Fix chill.test.sh in the Debian-specific context + chill.test.sh loads src/cold/chill.lisp, which itself loads + src/compiler/vop-existsp.lisp, but using the SYS logical pathname host. + This fails at build time because debian/rules has initialized the SYS logical + host to /usr/share/sbcl-source/ in the Lisp image (and this will also break + in the autopkgtest because the sbcl-source package is not installed there). + . + This patch therefore switches back the SYS logical host to the current build + directory. +Author: Sébastien Villemot +Forwarded: not-needed +Last-Update: 2021-08-25 +--- +This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ +--- a/tests/chill.test.sh ++++ b/tests/chill.test.sh +@@ -4,7 +4,8 @@ set -e + cd .. # for package-data-list + # The function SB-C:LOCATION-NUMBER does not get defined for all backends, + # and may get dropped by the tree shaker. +-run_sbcl --load src/cold/chill.lisp \ ++run_sbcl --eval "(sb-ext:set-sbcl-source-location \"$SBCL_PWD/..\")" \ ++ --load src/cold/chill.lisp \ + --eval '(assert (eq :external (nth-value 1 (find-symbol "LOCATION-NUMBER" "SB-C"))))' \ + --quit + diff -Nru sbcl-2.1.1/debian/patches/kfreebsd-pthread-futex.patch sbcl-2.1.11/debian/patches/kfreebsd-pthread-futex.patch --- sbcl-2.1.1/debian/patches/kfreebsd-pthread-futex.patch 2020-12-09 12:40:17.000000000 +0000 +++ sbcl-2.1.11/debian/patches/kfreebsd-pthread-futex.patch 2021-11-30 18:28:16.000000000 +0000 @@ -17,7 +17,7 @@ endif --- a/src/runtime/thread.c +++ b/src/runtime/thread.c -@@ -668,7 +668,7 @@ static void attach_os_thread(init_thread +@@ -714,7 +714,7 @@ static void attach_os_thread(init_thread # else pthread_attr_t attr; pthread_attr_init(&attr); diff -Nru sbcl-2.1.1/debian/patches/series sbcl-2.1.11/debian/patches/series --- sbcl-2.1.1/debian/patches/series 2021-02-03 20:34:45.000000000 +0000 +++ sbcl-2.1.11/debian/patches/series 2021-12-01 10:15:07.000000000 +0000 @@ -5,4 +5,5 @@ disable-timer-test.patch skip-some-autopkgtests.patch disable-fcb-threads-test.patch -skip-stack-scan-precise-gencgc.patch +fix-chill-test.patch +vop-existsp-test.patch diff -Nru sbcl-2.1.1/debian/patches/skip-some-autopkgtests.patch sbcl-2.1.11/debian/patches/skip-some-autopkgtests.patch --- sbcl-2.1.1/debian/patches/skip-some-autopkgtests.patch 2020-04-27 21:18:49.000000000 +0000 +++ sbcl-2.1.11/debian/patches/skip-some-autopkgtests.patch 2021-08-25 10:08:35.000000000 +0000 @@ -1,9 +1,11 @@ Description: Skip some tests when run with autopkgtest - Those tests need to rebuild either libsbcl.a or shrinkwrap-sbcl, which can’t - easily be done within autopkgtest. + - elfcore.test.sh and relocation.test.sh need to rebuild either libsbcl.a or + shrinkwrap-sbcl, which can’t easily be done within autopkgtest. + - run-sbcl.test.sh does not make sense in an autopkgtest context, since its + purpose is to test a not-yet-installed sbcl binary. Author: Sébastien Villemot Forwarded: not-needed -Last-Update: 2020-03-08 +Last-Update: 2021-08-25 --- This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ --- a/tests/elfcore.test.sh @@ -28,3 +30,16 @@ then # shell tests don't have a way of exiting as "not applicable" exit $EXIT_TEST_WIN +--- a/tests/run-sbcl.test.sh ++++ b/tests/run-sbcl.test.sh +@@ -1,5 +1,10 @@ + set -e + ++if [ -n "${AUTOPKGTEST_TMP:-}" ] ++then ++ exit $EXIT_TEST_WIN ++fi ++ + . ./subr.sh + + # run-sbcl.sh's pathname munging turns out always to have been diff -Nru sbcl-2.1.1/debian/patches/skip-stack-scan-precise-gencgc.patch sbcl-2.1.11/debian/patches/skip-stack-scan-precise-gencgc.patch --- sbcl-2.1.1/debian/patches/skip-stack-scan-precise-gencgc.patch 2021-02-03 20:36:39.000000000 +0000 +++ sbcl-2.1.11/debian/patches/skip-stack-scan-precise-gencgc.patch 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -Description: Skip stack scan in precise gencgc's save-lisp-and-die - Fixes FTBFS on arm64: - -Origin: upstream, https://sourceforge.net/p/sbcl/sbcl/ci/b32d134759519fdf5b30699b85f9d99a7e74dc95/ -Bug: https://bugs.launchpad.net/sbcl/+bug/1914235 -Last-Update: 2021-02-03 ---- -This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ ---- a/src/runtime/gencgc.c -+++ b/src/runtime/gencgc.c -@@ -3654,9 +3654,9 @@ garbage_collect_generation(generation_in - #if GENCGC_IS_PRECISE - /* - * If not x86, we need to scavenge the interrupt context(s) and the -- * control stack. -+ * control stack, unless in final GC then don't. - */ -- { -+ if (conservative_stack) { - struct thread *th; - for_each_thread(th) { - scavenge_interrupt_contexts(th); diff -Nru sbcl-2.1.1/debian/patches/testsuite-homedir.patch sbcl-2.1.11/debian/patches/testsuite-homedir.patch --- sbcl-2.1.1/debian/patches/testsuite-homedir.patch 2019-08-11 19:41:22.000000000 +0000 +++ sbcl-2.1.11/debian/patches/testsuite-homedir.patch 2021-08-24 18:58:05.000000000 +0000 @@ -11,7 +11,7 @@ This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ --- a/tests/filesys.pure.lisp +++ b/tests/filesys.pure.lisp -@@ -267,11 +267,11 @@ +@@ -282,11 +282,11 @@ (with-test (:name (file-author stringp)) #-win32 diff -Nru sbcl-2.1.1/debian/patches/vop-existsp-test.patch sbcl-2.1.11/debian/patches/vop-existsp-test.patch --- sbcl-2.1.1/debian/patches/vop-existsp-test.patch 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/debian/patches/vop-existsp-test.patch 2021-12-01 10:43:50.000000000 +0000 @@ -0,0 +1,19 @@ +Description: Fix no-v0p-ex1stsp-in-build with sb-xref-for-internals + We build the Debian package with fancy features, which include + sb-xref-for-internals. + With this feature, VOP-EXISTSP remains in the Lisp image, hence we need + to skip the test that checks for its absence. +Author: Sébastien Villemot +Bug: https://bugs.launchpad.net/sbcl/+bug/1952896 +Last-Update: 2021-12-01 +--- +This patch header follows DEP-3: http://dep.debian.net/deps/dep3/ +--- a/tests/interface.pure.lisp ++++ b/tests/interface.pure.lisp +@@ -310,5 +310,5 @@ + '(1 2 3 4 5 6 7 8))))) + + (with-test (:name :no-v0p-ex1stsp-in-build ; spelled L33t Hax0r style on purpose +- :skipped-on :sb-devel) ; (otherwise self-induced failure) ++ :skipped-on (:or :sb-devel :sb-xref-for-internals)) ; (otherwise self-induced failure) + (assert (null (apropos-list "VOP-EXISTSP")))) diff -Nru sbcl-2.1.1/debian/rules sbcl-2.1.11/debian/rules --- sbcl-2.1.1/debian/rules 2020-12-28 09:18:10.000000000 +0000 +++ sbcl-2.1.11/debian/rules 2021-09-05 14:55:56.000000000 +0000 @@ -4,12 +4,17 @@ export DH_VERBOSE=1 -# Try to build with clisp by default on archs for which sbcl has not yet been bootstrapped. -# This list must be kept in sync with the Build-Depends field. -# As soon as a new arch is bootstrapped, it should be added here. +# Try to build with clisp by default on archs for which sbcl has not yet been bootstrapped +# (or with ecl if clisp is not available). +# Those lists must be kept in sync with the Build-Depends field. +# As soon as a new arch is bootstrapped, the lists should be updated. # See https://bugs.debian.org/954031 ifeq (,$(filter amd64 arm64 armel armhf i386 kfreebsd-amd64 powerpc ppc64 ppc64el, $(DEB_HOST_ARCH))) - BOOTSTRAPLISP := clisp +ifneq (,$(filter riscv64 sh4, $(DEB_HOST_ARCH))) + BOOTSTRAPLISP := /usr/bin/ecl --norc +else + BOOTSTRAPLISP := /usr/bin/clisp -norc +endif endif ifeq (,$(BOOTSTRAPLISP)) @@ -35,6 +40,7 @@ dh $@ override_dh_auto_configure: + # See doc/PACKAGING-SBCL.txt echo "\"$(DEB_VERSION_UPSTREAM).debian\"" > version.lisp-expr override_dh_auto_build: diff -Nru sbcl-2.1.1/debian/sbcl.lintian-overrides sbcl-2.1.11/debian/sbcl.lintian-overrides --- sbcl-2.1.1/debian/sbcl.lintian-overrides 2019-02-26 09:00:01.000000000 +0000 +++ sbcl-2.1.11/debian/sbcl.lintian-overrides 2021-08-25 09:52:17.000000000 +0000 @@ -1,5 +1,2 @@ sbcl: script-not-executable sbcl: unusual-interpreter - -# SBCL does not support PIE, and explicitly disables it at build-time -sbcl: hardening-no-pie usr/bin/sbcl diff -Nru sbcl-2.1.1/debian/sbcl.postinst sbcl-2.1.11/debian/sbcl.postinst --- sbcl-2.1.1/debian/sbcl.postinst 2019-02-26 09:00:01.000000000 +0000 +++ sbcl-2.1.11/debian/sbcl.postinst 2021-08-23 08:55:39.000000000 +0000 @@ -2,7 +2,7 @@ # postinst script for sbcl set -e -if [ "$1" = "configure" ] && which update-binfmts >/dev/null; then +if [ "$1" = "configure" ] && command -v update-binfmts >/dev/null; then update-binfmts --import sbcl || true fi diff -Nru sbcl-2.1.1/debian/sbcl.prerm sbcl-2.1.11/debian/sbcl.prerm --- sbcl-2.1.1/debian/sbcl.prerm 2019-02-26 09:00:01.000000000 +0000 +++ sbcl-2.1.11/debian/sbcl.prerm 2021-08-23 08:55:54.000000000 +0000 @@ -15,7 +15,7 @@ case "$1" in remove|upgrade|deconfigure) - if which update-binfmts >/dev/null; then + if command -v update-binfmts >/dev/null; then update-binfmts --package sbcl --remove sbcl /usr/lib/sbcl/sbcl-run \ || true fi diff -Nru sbcl-2.1.1/debian/upstream/metadata sbcl-2.1.11/debian/upstream/metadata --- sbcl-2.1.1/debian/upstream/metadata 2020-07-21 06:51:12.000000000 +0000 +++ sbcl-2.1.11/debian/upstream/metadata 2021-08-25 09:56:09.000000000 +0000 @@ -1,2 +1,7 @@ Archive: SourceForge Repository: git://git.code.sf.net/p/sbcl/sbcl +Repository-Browse: https://sourceforge.net/p/sbcl/sbcl/ci/master/tree/ +Bug-Database: https://bugs.launchpad.net/sbcl +Bug-Submit: https://bugs.launchpad.net/sbcl/+filebug +Documentation: http://sbcl.org/manual/index.html +Changelog: http://sbcl.org/all-news.html diff -Nru sbcl-2.1.1/.dir-locals.el sbcl-2.1.11/.dir-locals.el --- sbcl-2.1.1/.dir-locals.el 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/.dir-locals.el 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,2 @@ +((nil . ((indent-tabs-mode . nil))) + (makefile-mode . ((indent-tabs-mode . t)))) diff -Nru sbcl-2.1.1/doc/clean.sh sbcl-2.1.11/doc/clean.sh --- sbcl-2.1.1/doc/clean.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/doc/clean.sh 2021-11-30 16:16:46.000000000 +0000 @@ -1,4 +1,4 @@ #!/bin/sh -(cd manual; sh clean.sh) -(cd internals; sh clean.sh) +(cd ./manual && sh ./clean.sh) +(cd ./internals && sh ./clean.sh) diff -Nru sbcl-2.1.1/doc/internals/foreign-linkage.texinfo sbcl-2.1.11/doc/internals/foreign-linkage.texinfo --- sbcl-2.1.1/doc/internals/foreign-linkage.texinfo 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/doc/internals/foreign-linkage.texinfo 2021-11-30 16:16:46.000000000 +0000 @@ -28,26 +28,18 @@ CMUCL does lazy linkage for code, keeps all foreign addresses in the linkage-table, and handles the initialization from C. We do eager -linkage for everything, maintain a separate -@code{*STATIC-FOREIGN-SYMBOLS*} just like on non-linkage-table ports -(this allows more code sharing between ports, makes thread-safety -easier to achieve, and cuts one jump's worth of overhead from stuff -like closure_tramp), and do the initialization from lisp. +linkage for everything, initialize only the runtime-critical symbols +from C, and initialize anything else from lisp. @subsection Nitty Gritty Details -Symbols in @code{*STATIC-FOREIGN-SYMBOLS*} are handled the old -fashioned way: linkage-table is only used for symbols resolved with -@code{dlsym(3)}. - On system startup @code{FOREIGN-REINIT} iterates through the @code{*LINKAGE-INFO*}, which is a hash-table mapping dynamic foreign names to @code{LINKAGE-INFO} structures, and calls @code{arch_write_linkage_table_entry} to write the appropriate entries to the linkage-table. -When a foreign symbol is referred to, it is first looked for in the -@code{*STATIC-FOREIGN-SYMBOLS*}. If not found, +When a foreign symbol is referred to, @code{ENSURE-FOREIGN-LINKAGE} is called, which looks for the corresponding entry in @code{*LINKAGE-INFO*}, creating one and writing the appropriate entry in the linkage table if necessary. @@ -98,12 +90,12 @@ @comment node-name, next, previous, up @section Lazy Alien Resolution -On linkage-table ports SBCL is able to deal with forward-references to +SBCL is able to deal with forward-references to aliens -- which is to say, compile and load code referring to aliens before the shared object containing the alien in question has been loaded. -This is handled by @code{ENSURE-DYNAMIC-FOREIGN-SYMBOL-ADDRESS}, which +This is handled by @code{ENSURE-FOREIGN-SYMBOL-LINKAGE}, which first tries to resolve the address in the loaded shared objects, but failing that records the alien as undefined and returns the address of a read/write/execute protected guard page for variables, and address diff -Nru sbcl-2.1.1/doc/internals-notes/array-ubsan sbcl-2.1.11/doc/internals-notes/array-ubsan --- sbcl-2.1.1/doc/internals-notes/array-ubsan 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/doc/internals-notes/array-ubsan 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,38 @@ + +Detection of access to unitialized arrays will be performed in one +of two ways, depending on whether the vector is specialized on T or +or a "bits" type. T vectors will use no-tls-marker as a poison value. +Char/numeric will contain one extra bit per element. +The reason for not using unbound-marker on simple-vector is that +it simplifies uses of simple-vectors that have language-level semantics +for UNBOUND-MARKER, including at least the CLOS implementation +and hash-table key/value pairs. A distinct poison value avoids having +to revise a lot of code that needs to read the unbound-marker without +trapping at the vop level. + +Without array-ubsan it should nonetheless be possible to obtain a similar +effect of array-ubsan for simple-vector. The setter / getter remain the same, +but there is no tracking of the origin of the array. +Origin tracking provides an indicator of which function to "blame" +for creating the array without initializing it, such as: + +debugger invoked on a SB-KERNEL:UNINITIALIZED-ELEMENT-ERROR @539A5AF1 in thread +#: + Element 0 of array + #<(SIMPLE-VECTOR 4) {1004FFA01F}> + was not assigned a value. +Origin=# + +Additionally, it should be possible to create uninitialized dynamic-extent +simple-vectors on non-precise gencgc platforms. +This is related to array-ubsan in as much as array-ubsan provides a good +indication as to where something might be going wrong before causing +application corruption. To do this, you want to compile your code in 0 safety +with array-ubsan, which will initialize dynamic-extent arrays with the trap +value. If all your tests pass (and assuming you have good coverage +in your tests), then you can remove array-ubsan, and the dynamic-extent +simple-vectors will (pending further changes) be uninitialized. +This affords a measurable speedup. In a test of creating 1000-element arrays +(repeated sufficiently many times to be able to eliminate measurement error), +it was observed that a vector takes 29 CPU cycles to create, vs 597 CPU cycles +to zero-initialize it. diff -Nru sbcl-2.1.1/doc/internals-notes/closure sbcl-2.1.11/doc/internals-notes/closure --- sbcl-2.1.1/doc/internals-notes/closure 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/doc/internals-notes/closure 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,40 @@ +Closure without CODE slot (#-metaspace) +--------------------------------------- +nvalues = len - 1 + +1 value: 1 value + name: +word 0: header [len=2] word 0: header [len=2] +word 1: addr word 1: addr +word 2: value word 2: value = closure-index-ref 0 +word 3: padding word 3: name = closure-index-ref 1 + +2 values: 2 values + name: +word 0: header: [len=3] word 0: header [len=4] +word 1: addr word 1: addr +word 2: value 0 word 2: value 0 = closure-index-ref 0 +word 3: value 1 word 3: value 1 = closure-index-ref 1 + word 4: pad = closure-index-ref 2 + word 5: name = closure-index-ref 3 + +Closure with CODE slot (#+metaspace) +------------------------------------ + +nvalues = len - 2 + +1 value: +word 0: header [len=3] word 0: header [len=4] +word 1: addr word 1: addr +word 2: code word 2: code +word 3: value word 3: value = closure-index-ref 0 + word 4: pad = closure-index-ref 1 + word 5: name = closure-index-ref 2 + +2 valuess: +word 0: header [len=4] word 0: header [len=4] +word 1: addr word 1: tramp +word 2: code word 2: code +word 3: value 0 word 3: value 0 = closure-index-ref 0 +word 4: value 1 word 4: value 1 = closure-index-ref 1 +word 5: pad word 5: name = closure-index-ref 2 + +In all cases, NAME is in (closure-index-ref c nvalues) diff -Nru sbcl-2.1.1/doc/internals-notes/metaspace sbcl-2.1.11/doc/internals-notes/metaspace --- sbcl-2.1.1/doc/internals-notes/metaspace 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/doc/internals-notes/metaspace 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,101 @@ +Metaspace will hold all instances of LAYOUT when SBCL is +built with the :METASPACE feature enabled. +In that case, LAYOUTs may only be directly pointed to by: + * thread stacks and registers + * the header word of an INSTANCE or FUNCALLABLE-INSTANCE + * a code header's boxed constant pool + +The reason for pointing to LAYOUTs only from a restricted set of heap +objects has to do with complications to pointer tracing. +Bear in mind that there will be a finalizer attached to each WRAPPER +which is responsibile for freeing the manually-managed LAYOUT when the +wrapper is deleted by the garbage collector. + +Consider the following hypothetical example in which an arbitrary +simple-vector could allegedly point to a layout. + + DYNAMIC SPACE | MANUAL POOL + -------------------------------------------------------------- + + "V": vector + +---------+ | + | header | | + +---------+ | + | length | + +---------+ pointer "a" + | elt 0 | ------------------\ + +---------+ \ + | elt 1 | | \ + +---------+ | \ + | v + | + "I": instance | "L": instance of LAYOUT + of SOME-OBJECT | for SOME-OBJECT type + +---------------| | +---------------+ + | header word | -------------> | header word | + | ptr to LAYOUT | pointer "b" | layout-layout | + +---------------+ | +---------------+ + | payload | | | pointer to | + | ... | | / | WRAPPER | + +---------------+ | / +---------------+ + | / | | + | / | type IDs | + / | ... | + pointer "c" / +---------------+ + ------------------ | bitmap | + v +---------------+ + + "W": WRAPPER for | + SOME-OBJECT type | + +-------------| | + | header word | | + | | | + +-------------+ | + | payload | | + | ... | | + +-------------+ | + | +------------------------------------------------------------------ + +Tracing the instance "I" obviously needs to read the metadata from LAYOUT "L". +In particular, scanning requires knowledge of the raw slot bitmap. +Because the tracing algorithm needs to access the LAYOUT anyway, it can additionally +treat pointer "c" as if it originated from instance "I" by calling the pointer fixing +method on "c", thereby enlivening wrapper "W". Fixing may require writing back +pointer "c" into "L" if the pointer's value changed. From that perspective, pointer +"b" acts like a strangely encoded pointer from "I" to to "W", +and the tracing logic is totally agnostic of the encoding/decoding mechanism. + +But now consider that pointer "b" can be changed (via CHANGE-CLASS), or more simply, +instance "I" could become unreachable. Then as far as the pointer graph looks, +there is no path from a live instance of SOME-OBJECT to the wrapper "W". +Therefore the garbage collector could free W and trigger W's finalizer which +should (eventually) free the manually allocated L despite that both L (and hence W) +are still reachable through the vector V. Nothing prevents user code from reading +the vector and so on, which would constitute use-after-free error. + +We could attempt to rememdy this by saying that *every* potential pointer +into the manual pool should be examined to see whether the target is a LAYOUT. +Such an approach would add considerable overhead, quite literally every pointer +might have to be doubly-dereferenced. Without loss of generality, we have depicted +a 2-element vector, but it could be a million-element vector, or a 100-element list. +Such overhead in determining whether every pointer points to manually-managed +memory is unacceptable. + +In contrast, the cost of reading the pointer "b" from "I" to "L" has to be paid +no matter what. So confining the extra check for LAYOUT -> WRAPPER pointers to +only the scan of instance header words represents a significant decrease from the +theoretical maximum number of heap words that would be scanned using +the pessimistic (or "conservative") approach. That is, treating as few +pointers as possible as potential pointers to manual pools is to be preferred. + +However, a similar situation with code objects arises. A code object must be +allowed to point directly to a LAYOUT because the code needs to assign the layout +into an instance. Conceivably the code could point to the wrapper instead, +but we don't necessarily have an extra machine register available exactly +when needed in the allocation sequence - a register that would be needed to +extract the layout from the wrapper. As with instance scanning, it should be +relatively benign to perform a small amount of extra work in GC to facilitate +assigning layouts in object constructors. This is definitely a trade-off, +however, code blobs are not as frequently occurring as say cons cells, +vectors, and general instances. diff -Nru sbcl-2.1.1/doc/internals-notes/threading-specials sbcl-2.1.11/doc/internals-notes/threading-specials --- sbcl-2.1.1/doc/internals-notes/threading-specials 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/doc/internals-notes/threading-specials 2021-11-30 16:16:46.000000000 +0000 @@ -724,7 +724,6 @@ = fasloader -SB-FASL:*STATIC-FOREIGN-SYMBOLS* SB-FASL:*ASSEMBLER-ROUTINES* SB-FASL:*FASL-FILE-TYPE* SB-FASL::FOP-LIST*-4 diff -Nru sbcl-2.1.1/doc/manual/docstrings.lisp sbcl-2.1.11/doc/manual/docstrings.lisp --- sbcl-2.1.1/doc/manual/docstrings.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/doc/manual/docstrings.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -414,7 +414,10 @@ (cond ((or key optional) (car x)) (t (clean (car x)))) (clean (cdr x) :key key :optional optional)))))) - (clean (sb-introspect:function-lambda-list (get-name doc)))))))) + (multiple-value-bind (ll unknown) (sb-introspect:function-lambda-list (get-name doc)) + (if unknown + (values nil t) + (clean ll)))))))) (defun get-string-name (x) (let ((name (get-name x))) @@ -739,7 +742,7 @@ ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" (defun texinfo-begin (doc &aux *print-pretty*) (let ((kind (get-kind doc))) - (format *texinfo-output* "@~A {~:(~A~)} ~(~A~@[ ~{~A~^ ~}~]~)~%" + (format *texinfo-output* "@~A {~:(~A~)} ~(~A~)" (case kind ((package constant variable) "defvr") @@ -748,15 +751,24 @@ (t "deffn")) (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) - (title-name doc) - ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo - ;; interactions,so we escape the ampersand -- amusingly for TeX. - ;; sbcl.texinfo defines macros that expand @andkey and friends to &key. - (mapcar (lambda (name) - (if (member name lambda-list-keywords) - (format nil "@and~A{}" (remove #\- (subseq (string name) 1))) - name)) - (lambda-list doc))))) + (title-name doc)) + (multiple-value-bind (lambda-list unknown) (lambda-list doc) + (cond (unknown + (format *texinfo-output* " @emph{lambda list not known}")) + ((not lambda-list)) + (t + ;; &foo would be amusingly bold in the pdf thanks to + ;; TeX/Texinfo interactions,so we escape the ampersand -- + ;; amusingly for TeX. sbcl.texinfo defines macros that + ;; expand @andkey and friends to &key. + (format *texinfo-output* " ~(~{~A~^ ~}~)" + (mapcar (lambda (name) + (if (member name lambda-list-keywords) + (format nil "@and~A{}" + (remove #\- (subseq (string name) 1))) + name)) + lambda-list))))) + (format *texinfo-output* "~%"))) (defun texinfo-inferred-body (doc) (when (member (get-kind doc) '(class structure condition)) diff -Nru sbcl-2.1.1/doc/manual/ffi.texinfo sbcl-2.1.11/doc/manual/ffi.texinfo --- sbcl-2.1.1/doc/manual/ffi.texinfo 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/doc/manual/ffi.texinfo 2021-11-30 16:16:46.000000000 +0000 @@ -26,6 +26,7 @@ * Foreign Data Structure Examples:: * Loading Shared Object Files:: * Foreign Function Calls:: +* Calling Lisp From C:: * Step-By-Step Example of the Foreign Function Interface:: @end menu @@ -718,7 +719,6 @@ * The alien-funcall Primitive:: * The define-alien-routine Macro:: * define-alien-routine Example:: -* Calling Lisp From C:: @end menu @node The alien-funcall Primitive @@ -883,40 +883,6 @@ The Lisp function @code{cfoo} will have two arguments (@var{str} and @var{a}) and two return values (@var{a} and @var{i}). -@node Calling Lisp From C -@comment node-name, next, previous, up -@subsection Calling Lisp From C - -Calling Lisp functions from C is sometimes possible, but is extremely -hackish and poorly supported as of SBCL 0.7.5. See @code{funcall0} -@dots{} @code{funcall3} in the runtime system. The arguments must be -valid SBCL object descriptors (so that e.g. fixnums must be -left-shifted by 2.) As of SBCL 0.7.5, the format of object descriptors -is documented only by the source code and, in parts, by the old CMUCL -@file{INTERNALS} documentation. - -Note that the garbage collector moves objects, and won't be -able to fix up any references in C variables. There are three -mechanisms for coping with this: - -@enumerate -@item -The @code{sb-ext:purify} moves all live Lisp -data into static or read-only areas such that it will never be moved -(or freed) again in the life of the Lisp session - -@item -@code{sb-sys:with-pinned-objects} is a macro which arranges for some -set of objects to be pinned in memory for the dynamic extent of its -body forms. On ports which use the generational garbage collector (most, -as of this writing) this affects exactly the specified objects. On -other ports it is implemented by turning off GC for the duration (so -could be said to have a whole-world granularity). - -@item -Disable GC, using the @code{without-gcing} macro. -@end enumerate - @c +@node Calling Lisp From C +@comment node-name, next, previous, up +@section Calling Lisp From C + +SBCL supports the calling of Lisp functions using the C calling +convention. This is useful for both defining callbacks and for creating +an interface for calling into Lisp as a shared library directly from C. + +The @code{define-alien-callable} macro wraps Lisp code and creates a C +foreign function which can be called with the C calling convention. + +@include macro-sb-alien-define-alien-callable.texinfo + +The @code{alien-callable-function} function returns the foreign callable +value associated with any name defined by @code{define-alien-callable}, +so that we can, for example, pass the callable value to C as a callback. + +@include fun-sb-alien-alien-callable-function.texinfo + +Note that the garbage collector moves objects, and won't be able to fix +up any references in C variables. There are three mechanisms for coping +with this: + +@enumerate +@item +The @code{sb-ext:purify} moves all live Lisp data into static or +read-only areas such that it will never be moved (or freed) again in the +life of the Lisp session + +@item +@code{sb-sys:with-pinned-objects} is a macro which arranges for some set +of objects to be pinned in memory for the dynamic extent of its body +forms. On ports which use the generational garbage collector (most, as +of this writing) this affects exactly the specified objects. On other +ports it is implemented by turning off GC for the duration (so could be +said to have a whole-world granularity). + +@item +Disable GC, using the @code{without-gcing} macro. +@end enumerate + +@menu +* Lisp as a Shared Library:: +@end menu + +@node Lisp as a Shared Library +@comment node-name, next, previous, up +@subsection Lisp as a Shared Library +SBCL supports the use of Lisp as a shared library that can be used by C +programs using the @code{define-alien-callable} interface. See the +@code{:callable-exports} keyword to @code{save-lisp-and-die} for how to +save the Lisp image in a way that allows a C program to initialize the +Lisp runtime and the exported symbols. When SBCL is built as a library, +it exposes the symbol @code{initialize_lisp} which can be used in +conjunction with a core initializing global symbols to foreign callables +as function pointers and with object code allocating those symbols to +initialize the runtime properly. The arguments to @code{initialize_lisp} +are the same as the arguments to the main @code{sbcl} +program. + +Note: There is currently no way to run exit hooks or otherwise undo +Lisp initialization gracefully from C. @node Step-By-Step Example of the Foreign Function Interface @comment node-name, next, previous, up diff -Nru sbcl-2.1.1/doc/manual/make-tempfiles.sh sbcl-2.1.11/doc/manual/make-tempfiles.sh --- sbcl-2.1.1/doc/manual/make-tempfiles.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/doc/manual/make-tempfiles.sh 2021-11-30 16:16:46.000000000 +0000 @@ -15,15 +15,13 @@ # else an installed sbcl is used. if [ -z "$1" ] ; then - . ../../sbcl-pwd.sh - sbcl_pwd - - sbclsystem=$SBCL_PWD/../../src/runtime/sbcl - sbclcore=$SBCL_PWD/../../output/sbcl.core + SBCL_TOP=../.. + sbclsystem=$SBCL_TOP/src/runtime/sbcl + sbclcore=$SBCL_TOP/output/sbcl.core if [ -f $sbclsystem ] && [ -f $sbclcore ] then SBCLRUNTIME="$sbclsystem --core $sbclcore" - SBCL_HOME=$SBCL_PWD/../../obj/sbcl-home/; export SBCL_HOME + SBCL_HOME=$SBCL_TOP/obj/sbcl-home/; export SBCL_HOME SBCL_BUILDING_CONTRIB="please asdf install your hook"; export SBCL_BUILDING_CONTRIB else SBCLRUNTIME="`command -v sbcl`" diff -Nru sbcl-2.1.1/doc/manual/threading.texinfo sbcl-2.1.11/doc/manual/threading.texinfo --- sbcl-2.1.1/doc/manual/threading.texinfo 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/doc/manual/threading.texinfo 2021-11-30 16:16:46.000000000 +0000 @@ -116,19 +116,11 @@ @unnumberedsubsec CAS Protocol -Our @code{compare-and-swap} is user-extensible using a protocol -similar to @code{setf}, allowing users to add CAS support to new -places via e.g. @code{defcas}. - -At the same time, new atomic operations can be built on top of CAS -using @code{get-cas-expansion}. See @code{atomic-update}, -@code{atomic-push}, and @code{atomic-pop} for examples of how to do -this. +Our @code{compare-and-swap} is user-extensible by defining functions +named (CAS place), allowing users to add CAS support to new +places. @include macro-sb-ext-cas.texinfo -@include macro-sb-ext-define-cas-expander.texinfo -@include macro-sb-ext-defcas.texinfo -@include fun-sb-ext-get-cas-expansion.texinfo @node Mutex Support @comment node-name, next, previous, up diff -Nru sbcl-2.1.1/float-math.lisp-expr sbcl-2.1.11/float-math.lisp-expr --- sbcl-2.1.1/float-math.lisp-expr 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/float-math.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -540,6 +540,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x-129194D8) #.(MAKE-SINGLE-FLOAT #x0)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #x-1) NIL) (< (#.(MAKE-SINGLE-FLOAT #x0) #x0) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x0)) NIL) @@ -552,6 +553,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F000000) #x0) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x3F000000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x4E800000)) T) @@ -562,6 +564,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x3FC90FDB) #.(MAKE-SINGLE-FLOAT #x3FC90FDB)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x3FC90FDB) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) T) (< (#.(MAKE-SINGLE-FLOAT #x3FC90FDB) #.(MAKE-SINGLE-FLOAT #x5E490FDB)) T) (< (#.(MAKE-SINGLE-FLOAT #x3FC90FDB) #.(MAKE-SINGLE-FLOAT #x5F490FDB)) T) @@ -619,18 +622,23 @@ (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1000000) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1FFFFFE1) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1FFFFFFB) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1FFFFFFC) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1FFFFFFF) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x20000001) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x3FFFFFFE) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x3FFFFFFF) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x7FFFFFFF) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #xFFFFFFFF) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x218DEF416BD) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x83126E978D4FD) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #xFFFFFF000000001) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #xFFFFFFFFFFFFFFB) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #xFFFFFFFFFFFFFFC) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #xFFFFFFFFFFFFFFF) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x1000000000000001) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x3FFFFFC000000001) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x3FFFFFFFFFFFFFFB) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x3FFFFFFFFFFFFFFC) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x3FFFFFFFFFFFFFFF) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x4000000000000001) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #x7FFFFFFFFFFFFFFF) NIL) @@ -641,6 +649,7 @@ (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18)) NIL) (< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) NIL) +(< (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (< (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) (< (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18)) T) @@ -652,6 +661,7 @@ (< (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x5FEFFFFF #xFFFFFFFF)) T) (< (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (< (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (< (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) @@ -699,6 +709,7 @@ (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x-20000001) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x-20000000) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-4006DE05 #x54442D18)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) @@ -713,12 +724,14 @@ (< (#.(MAKE-DOUBLE-FLOAT #x3FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x3FEFFFFF #xFFFFFFFF)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF)) T) (< (#.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333) #.(MAKE-DOUBLE-FLOAT #x3FE6A09E #x667F3BCD)) NIL) +(< (#.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333) #.(MAKE-DOUBLE-FLOAT #x3FF33333 #x33333333)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18)) NIL) (< (#.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x41D921FB #x54442D18)) T) (< (#.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x43C921FB #x54442D18)) T) @@ -913,8 +926,17 @@ (<= (#x1 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x4B800000)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x4E6E6B28)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x5CEE6B28)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x6C6E6B28)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x6D6E6B28)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-DOUBLE-FLOAT #x458DCD65 #x0)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-DOUBLE-FLOAT #x45ADCD65 #x0)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x0)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x5903126F)) T) @@ -925,6 +947,9 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x0)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3DCCCCCD)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x3FC90FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x5E490FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x5F490FDB)) T) @@ -976,10 +1001,14 @@ (<= (#.(MAKE-SINGLE-FLOAT #x-129194D8) #.(MAKE-SINGLE-FLOAT #x0)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-129194D8) #.(MAKE-SINGLE-FLOAT #x6D6E6B28)) T) (<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x-800000) #.(MAKE-SINGLE-FLOAT #x-800000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #x1) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #x3FFFFFF7) T) +(<= (#.(MAKE-SINGLE-FLOAT #x0) #x7FFFFFFD) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #x1FFFFFFFFFFFFFF7) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #x7FFFFFFFFFFFFFF7) T) +(<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40804189)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40800011)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) @@ -1023,6 +1052,7 @@ (<= (#.(MAKE-SINGLE-FLOAT #x3F7FFFEF) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x3F7FFFEF) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) T) (<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x1FFFFFFC) T) +(<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x3FFFFFFF) T) (<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #xFFFFFFFFFFFFFFC) T) (<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x3FFFFFFFFFFFFFFC) T) (<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) @@ -1030,6 +1060,8 @@ (<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) (<= (#.(MAKE-SINGLE-FLOAT #x3FC90FDB) #.(MAKE-SINGLE-FLOAT #x3FC90FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x40490FDB) #.(MAKE-SINGLE-FLOAT #x40490FDB)) T) (<= (#.(MAKE-SINGLE-FLOAT #x447A0000) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL) @@ -1099,11 +1131,23 @@ (<= (#.(MAKE-SINGLE-FLOAT #x6D6E6B28) #.(MAKE-SINGLE-FLOAT #x6D6E6B28)) T) (<= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (<= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(<= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-SINGLE-FLOAT #x7F800000) #.(MAKE-SINGLE-FLOAT #x7F800000)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x400921FB #x54442D18)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x40734413 #x509F79FF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x408628B7 #x6E3A7B61)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x43400000 #x0)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x458DCD65 #x0)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x45ADCD65 #x0)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x5FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) @@ -1205,6 +1249,7 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x-3A52329B #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-3A52329B #x0) #.(MAKE-DOUBLE-FLOAT #x45ADCD65 #x0)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-500001 #xFFFFFFFE) #x0) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-SINGLE-FLOAT #x-800001)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x0) T) (<= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x1FFFFFFF) T) @@ -1258,6 +1303,8 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x3FE6A09E #x667F3BCD) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x3FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x3FEFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) +(<= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) (<= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) @@ -1396,6 +1443,7 @@ (<= (#.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF)) T) +(<= (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (<= (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) @@ -1707,6 +1755,8 @@ (= (#x20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x20000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x3FFFFFF7 #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#x3FFFFFFF #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) +(= (#x7FFFFFFD #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#xFFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#xFFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x1000000000000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) @@ -1718,7 +1768,10 @@ (= (#x4000000000000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x7FFFFFFFFFFFFFF7 #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-80000000) #x0) T) +(= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) +(= (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-40800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) @@ -1729,22 +1782,34 @@ (= (#.(MAKE-SINGLE-FLOAT #x-21B6F025) #.(MAKE-SINGLE-FLOAT #x-21B6F025)) T) (= (#.(MAKE-SINGLE-FLOAT #x-21800000) #.(MAKE-SINGLE-FLOAT #x-21800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-20B6F025) #.(MAKE-SINGLE-FLOAT #x-20B6F025)) T) +(= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #x-1) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #x0) T) (= (#.(MAKE-SINGLE-FLOAT #x0) #x1) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #x3FFFFFF7) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #x7FFFFFFD) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #x1FFFFFFFFFFFFFF7) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #x7FFFFFFFFFFFFFF7) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40804189)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40800011)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-319194D8)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-31800000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-231194D8)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-22000000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-21000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-139194D8)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-129194D8)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5E000000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5F000000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-3A72329B #x0)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-3A52329B #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) T) @@ -1754,11 +1819,14 @@ (= (#.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x4E800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x0) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x1FFFFFFC) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x3FFFFFFF) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #xFFFFFFFFFFFFFFC) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #x3FFFFFFFFFFFFFFC) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) +(= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (= (#.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x-32000000)) NIL) @@ -1785,8 +1853,12 @@ (= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x5F490FDB) #.(MAKE-SINGLE-FLOAT #x-20B6F025)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x5F490FDB) #.(MAKE-SINGLE-FLOAT #x5F490FDB)) T) +(= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #x0) T) (= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-SINGLE-FLOAT #x0)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x20100000 #x1)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x40100000 #x0)) NIL) @@ -1809,6 +1881,7 @@ (= (#.(MAKE-DOUBLE-FLOAT #x-3C300000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3C16DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3C16DE05 #x54442D18)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-500001 #xFFFFFFFE) #x0) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF) #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x-4000000000000001) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x-4000000000000000) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x-1000000000000001) NIL) @@ -1827,12 +1900,19 @@ (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x4000000000000001) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-SINGLE-FLOAT #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-4006DE05 #x54442D18)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3F8BCB1A #x420F4374)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3F78B6F0 #xD52D3052)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3E300000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C400000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C300000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C200000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3A72329B #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3A52329B #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x41D00000 #x0)) NIL) @@ -1900,16 +1980,19 @@ (= (#.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF)) T) (= (#.(MAKE-DOUBLE-FLOAT #x5FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (= (#x-4000000000000000 #x3FFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x-1000000000000000 #xFFFFFFFFFFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x-20000000 #x1FFFFFFF #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#x-1 #x3FFFFFF7 #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#x-1 #x7FFFFFFD #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#x-1 #x1FFFFFFFFFFFFFF7 #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#x-1 #x7FFFFFFFFFFFFFF7 #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#x0 #x0 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (= (#x0 #x1 #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#x0 #x1FFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) +(= (#x0 #x3FFFFFFF #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#x0 #xFFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#x0 #x3FFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (= (#x0 #.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #x0) NIL) @@ -1957,12 +2040,17 @@ (= (#x0 #.(MAKE-DOUBLE-FLOAT #x5FCFFFFF #xFFFFFFFF) #x0) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x0)) T) +(= (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x-34800000) #x0 #x0) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-34800000) #.(MAKE-SINGLE-FLOAT #x-34800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-32000000) #x0 #x0) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x-32000000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x-32000000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-32000000) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x-319194D8) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-31800000) #.(MAKE-SINGLE-FLOAT #x4E800000) #x0) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-31800000) #.(MAKE-SINGLE-FLOAT #x4E800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-31400000) #x0 #x0) NIL) @@ -1970,6 +2058,7 @@ (= (#.(MAKE-SINGLE-FLOAT #x-3136F025) #.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x-3136F025)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-3136F025) #.(MAKE-SINGLE-FLOAT #x4EC90FDB) #.(MAKE-SINGLE-FLOAT #x4EC90FDB)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-231194D8) #x0 #x0) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x-231194D8) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-22800000) #x0 #x0) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-22800000) #.(MAKE-SINGLE-FLOAT #x-22800000) #.(MAKE-SINGLE-FLOAT #x-22800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x-22800000) #.(MAKE-SINGLE-FLOAT #x5D7FFFFF) #.(MAKE-SINGLE-FLOAT #x-22800000)) NIL) @@ -1989,17 +2078,29 @@ (= (#.(MAKE-SINGLE-FLOAT #x-20B6F025) #.(MAKE-SINGLE-FLOAT #x5F490FDB) #.(MAKE-SINGLE-FLOAT #x-20B6F025)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-20B6F025) #.(MAKE-SINGLE-FLOAT #x5F490FDB) #.(MAKE-SINGLE-FLOAT #x5F490FDB)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-139194D8) #x0 #x0) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x-139194D8) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x-129194D8) #x0 #x0) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x-129194D8) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x3F000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E6E6B28) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x4E800000) #.(MAKE-SINGLE-FLOAT #x3F000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5CEE6B28) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x6C6E6B28) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x6D6E6B28) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x458DCD65 #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) +(= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x45ADCD65 #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) T) (= (#.(MAKE-SINGLE-FLOAT #x3D800000) #.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3D800000)) NIL) (= (#.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x3F000000) #.(MAKE-SINGLE-FLOAT #x3F000000)) T) (= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) T) +(= (#.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-SINGLE-FLOAT #x3F800000) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) (= (#.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF) #.(MAKE-SINGLE-FLOAT #x4B7FFFFF)) T) (= (#.(MAKE-SINGLE-FLOAT #x4E000000) #.(MAKE-SINGLE-FLOAT #x4E000000) #.(MAKE-SINGLE-FLOAT #x4E000000)) T) (= (#.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x538637BD) #.(MAKE-SINGLE-FLOAT #x538637BD)) T) @@ -2008,7 +2109,15 @@ (= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) +(= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-4006DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3F8BCB1A #x420F4374) #x0 #x0) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3F8BCB1A #x420F4374) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3F78B6F0 #xD52D3052) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3F72231A #x420F4374) #x0 #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #x0 #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) T) @@ -2029,6 +2138,8 @@ (= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #x0 #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3CC00000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #x0 #x0) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3C62329C #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #x0 #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3C500000 #x0)) NIL) @@ -2050,13 +2161,25 @@ (= (#.(MAKE-DOUBLE-FLOAT #x-3C16DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x43E921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-3C16DE05 #x54442D18)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3C16DE05 #x54442D18) #.(MAKE-DOUBLE-FLOAT #x43E921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x43E921FB #x54442D18)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3A72329B #x0) #x0 #x0) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3A72329B #x0) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3A72329B #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-3A52329B #x0) #x0 #x0) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3A52329B #x0) #.(MAKE-SINGLE-FLOAT #x-80000000) #.(MAKE-SINGLE-FLOAT #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x-3A52329B #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x-500001 #xFFFFFFFE) #x0 #x0) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x3FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF921FB #x54442D18) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x40734413 #x509F79FF) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x4083C273 #x2107A1BA) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x408628B7 #x6E3A7B61) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x41CFFFFF #xFF800000) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x439DCD64 #xFF1194D8) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x458DCD65 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x45ADCD65 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x5FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x3FB99999 #x9999999A) #.(MAKE-DOUBLE-FLOAT #x3FB99999 #x9999999A) #.(MAKE-DOUBLE-FLOAT #x3FB99999 #x9999999A)) T) (= (#.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) T) (= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0)) T) @@ -2081,6 +2204,7 @@ (= (#.(MAKE-SINGLE-FLOAT #x5F000000) #.(MAKE-SINGLE-FLOAT #x-21000000) #x0 #x0) NIL) (= (#.(MAKE-SINGLE-FLOAT #x5F000000) #.(MAKE-SINGLE-FLOAT #x-21000000) #.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) NIL) +(= (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x4083C273 #x2107A1BA) #.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0) #.(MAKE-DOUBLE-FLOAT #x3FE00000 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (= (#.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x-3E400000 #x0)) NIL) @@ -2124,6 +2248,7 @@ (> (#x0 #.(MAKE-SINGLE-FLOAT #x6C6E6B28)) NIL) (> (#x0 #.(MAKE-SINGLE-FLOAT #x6D6E6B28)) NIL) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) +(> (#x0 #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x-3E26DE05 #x54442D18)) T) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C36DE05 #x54442D18)) T) (> (#x0 #.(MAKE-DOUBLE-FLOAT #x-3C16DE05 #x54442D18)) T) @@ -2155,6 +2280,8 @@ (> (#x20000000 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (> (#x20000001 #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (> (#x3FFFFFF7 #.(MAKE-SINGLE-FLOAT #x0)) T) +(> (#x3FFFFFFF #.(MAKE-SINGLE-FLOAT #x3F800000)) T) +(> (#x7FFFFFFD #.(MAKE-SINGLE-FLOAT #x0)) T) (> (#x10C6F7A0B5E #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) NIL) (> (#x4189374BC6A7E #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) NIL) (> (#xFFFFFFFFFFFFFFC #.(MAKE-SINGLE-FLOAT #x3F800000)) T) @@ -2185,14 +2312,17 @@ (> (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40804189) #.(MAKE-SINGLE-FLOAT #x5903126F)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x-40800011)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x3F7FFFEF)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800011) #.(MAKE-SINGLE-FLOAT #x540637BD)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x40E00000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x4E000000)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x4E800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x5D800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-40800000) #.(MAKE-SINGLE-FLOAT #x5E800000)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-4036F025)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-3136F025)) T) (> (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-21B6F025)) T) (> (#.(MAKE-SINGLE-FLOAT #x-4036F025) #.(MAKE-SINGLE-FLOAT #x-20B6F025)) T) @@ -2235,6 +2365,7 @@ (> (#.(MAKE-SINGLE-FLOAT #x-129194D8) #.(MAKE-SINGLE-FLOAT #x-129194D8)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-129194D8) #.(MAKE-SINGLE-FLOAT #x6D6E6B28)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-800001)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-DOUBLE-FLOAT #x-100001 #xFFFFFFFF)) T) (> (#.(MAKE-SINGLE-FLOAT #x-800000) #.(MAKE-SINGLE-FLOAT #x-800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #x-1) T) (> (#.(MAKE-SINGLE-FLOAT #x0) #x0) NIL) @@ -2263,6 +2394,7 @@ (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5903126F)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5D800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5E800000)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x800000) #.(MAKE-SINGLE-FLOAT #x800000)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x3089705F) #.(MAKE-SINGLE-FLOAT #x3089705F)) NIL) @@ -2336,8 +2468,10 @@ (> (#.(MAKE-SINGLE-FLOAT #x5F490FDB) #x0) T) (> (#.(MAKE-SINGLE-FLOAT #x5F490FDB) #.(MAKE-SINGLE-FLOAT #x5F490FDB)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) +(> (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-DOUBLE-FLOAT #x7FEFFFFF #xFFFFFFFF)) NIL) (> (#.(MAKE-SINGLE-FLOAT #x7F800000) #.(MAKE-SINGLE-FLOAT #x7F800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #x0) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x20100000 #x1)) NIL) @@ -2352,6 +2486,7 @@ (> (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x5FEFFFFF #xFFFFFFFF)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-7FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-7FF00000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-402D413D #x33018866) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) +(> (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-3F8BC000 #x0)) T) @@ -2465,7 +2600,9 @@ (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x1000000000000001) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x4000000000000000) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #x4000000000000001) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) +(> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-4006DE05 #x54442D18)) T) (> (#.(MAKE-DOUBLE-FLOAT #x0 #x0) #.(MAKE-DOUBLE-FLOAT #x-3F8CB000 #x0)) T) @@ -2518,6 +2655,9 @@ (> (#.(MAKE-DOUBLE-FLOAT #x3FE6A09E #x667F3BCD) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (> (#.(MAKE-DOUBLE-FLOAT #x3FE6A09E #x667F3BCD) #.(MAKE-DOUBLE-FLOAT #x3FE6A09E #x667F3BCD)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x3FEFFFFF #xFFFFFFFF) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) +(> (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #x0) T) +(> (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x-40800000)) T) +(> (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x0)) T) (> (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x3F800000)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) (> (#.(MAKE-DOUBLE-FLOAT #x3FF00000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) @@ -2753,6 +2893,7 @@ (>= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x-80000000)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x-800001) #.(MAKE-SINGLE-FLOAT #x7F7FFFFF)) NIL) +(>= (#.(MAKE-SINGLE-FLOAT #x-800000) #.(MAKE-SINGLE-FLOAT #x-800000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x0) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x0) #x1) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) @@ -2773,6 +2914,7 @@ (>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x538637BD)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-SINGLE-FLOAT #x5883126F)) NIL) (>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x0) #.(MAKE-DOUBLE-FLOAT #x0 #x0)) T) (>= (#.(MAKE-SINGLE-FLOAT #x3089705F) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x358637BD) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x358637BD) #.(MAKE-SINGLE-FLOAT #x40000000)) NIL) @@ -2828,10 +2970,12 @@ (>= (#.(MAKE-SINGLE-FLOAT #x5E7FFFFF) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #x0) T) (>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x-21800000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x5E800000) #.(MAKE-SINGLE-FLOAT #x5E800000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x-80000000)) T) (>= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x-800001)) T) (>= (#.(MAKE-SINGLE-FLOAT #x7F7FFFFF) #.(MAKE-SINGLE-FLOAT #x0)) T) +(>= (#.(MAKE-SINGLE-FLOAT #x7F800000) #.(MAKE-SINGLE-FLOAT #x7F800000)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #x0) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-80000000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) @@ -2842,6 +2986,7 @@ (>= (#.(MAKE-DOUBLE-FLOAT #x-402D413D #x33018866) #x0) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-402D413D #x33018866) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) (>= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #x0) NIL) +(>= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-SINGLE-FLOAT #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-80000000 #x0)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-402D413D #x33018866)) NIL) (>= (#.(MAKE-DOUBLE-FLOAT #x-40100000 #x0) #.(MAKE-DOUBLE-FLOAT #x-40100000 #x0)) T) @@ -3190,11 +3335,14 @@ (COERCE (#x1FFFFFE0 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xE0000000)) (COERCE (#x1FFFFFE1 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4DFFFFFF)) (COERCE (#x1FFFFFFB SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000)) +(COERCE (#x1FFFFFFC SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000)) (COERCE (#x1FFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41BFFFFF #xFF000000)) (COERCE (#x1FFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000)) (COERCE (#x20000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41C00000 #x0)) (COERCE (#x20000000 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000)) (COERCE (#x20000001 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E000000)) +(COERCE (#x3FFFFFFE SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E800000)) +(COERCE (#x3FFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4E800000)) (COERCE (#x7FFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41DFFFFF #xFFC00000)) (COERCE (#x7FFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x4F000000)) (COERCE (#x80000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x41E00000 #x0)) @@ -3210,6 +3358,7 @@ (COERCE (#xFFFFFF000000001 SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5D7FFFFF)) (COERCE (#xFFFFFFFFFFFFF81 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43AFFFFF #xFFFFFFFF)) (COERCE (#xFFFFFFFFFFFFFFB SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5D800000)) +(COERCE (#xFFFFFFFFFFFFFFC SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5D800000)) (COERCE (#xFFFFFFFFFFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) (COERCE (#xFFFFFFFFFFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5D800000)) (COERCE (#x1000000000000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43B00000 #x0)) @@ -3220,6 +3369,7 @@ (COERCE (#x3FFFFFFFFFFFFE01 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43CFFFFF #xFFFFFFFF)) (COERCE (#x3FFFFFFFFFFFFFC0 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43D00000 #x0)) (COERCE (#x3FFFFFFFFFFFFFFB SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5E800000)) +(COERCE (#x3FFFFFFFFFFFFFFC SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5E800000)) (COERCE (#x3FFFFFFFFFFFFFFF DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43D00000 #x0)) (COERCE (#x3FFFFFFFFFFFFFFF SINGLE-FLOAT) #.(MAKE-SINGLE-FLOAT #x5E800000)) (COERCE (#x4000000000000000 DOUBLE-FLOAT) #.(MAKE-DOUBLE-FLOAT #x43D00000 #x0)) diff -Nru sbcl-2.1.1/freeze.sh sbcl-2.1.11/freeze.sh --- sbcl-2.1.1/freeze.sh 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/freeze.sh 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,171 @@ +#! /bin/bash + +# Sourceforge username +SFUSER=${SFUSER:-$USER} + +set -ex + +usage() { + if ! [ -z "$1" ] + then + echo $1 + fi + cat < /dev/null + then + echo "NEWS not in correct format!" + exit 1 + fi + + ## Make draft release notes + + if [ ! -f $SBCL_RELEASE_DIR/sbcl-$VERSION-release-notes.txt ]; then + awk "BEGIN { state = 0 } + /^changes relative to sbcl-/ { state = 1 } + /^changes in sbcl-/ { state = 0 } + { if(state == 1) print \$0 }" < $GIT_DIR/NEWS > $SBCL_RELEASE_DIR/sbcl-$VERSION-release-notes.txt + fi + + ## Tag + + # I'd like to use the same tag each time, but I can't convince + # myself that that will do the right thing when pushed, and I don't + # want to break all our mirrors for this. + + # echo "Tagging as release_candidate" + # git tag release_candidate + + git clone $GIT_DIR $SBCL_DIR +fi + +# check self-build (without float oracle) + +## Build x86-64 binary for bootstrap. + +if [ ! -d $SBCL_RELEASE_DIR/bin ]; then + echo "Building bootstrap x86-64 binary" + cd $SBCL_DIR + nice -20 ./make.sh >$LOGFILE 2>&1 + + cd tests + nice -20 sh ./run-tests.sh >>$LOGFILE 2>&1 + mkdir -p $SBCL_RELEASE_DIR/bin + cp $SBCL_DIR/src/runtime/sbcl $SBCL_RELEASE_DIR/bin/sbcl + cp $SBCL_DIR/output/sbcl.core $SBCL_RELEASE_DIR/bin/sbcl.core +fi + +## Build x86-64 release candidate binary. + +if [ ! -d $SBCL_RELEASE_DIR/sbcl-$VERSION-x86-64-linux ]; then + echo "Building release candidate x86-64 binary" + cd $SBCL_DIR + sh clean.sh + nice -20 ./make.sh "$SBCL_RELEASE_DIR/bin/sbcl --core $SBCL_RELEASE_DIR/bin/sbcl.core --no-userinit" >> $LOGFILE 2>&1 + cd doc && sh ./make-doc.sh + cd $SBCL_RELEASE_DIR + + ln -s $SBCL_DIR $SBCL_RELEASE_DIR/sbcl-$VERSION-x86-64-linux + sh $SBCL_DIR/binary-distribution.sh sbcl-$VERSION-x86-64-linux + bzip2 sbcl-$VERSION-x86-64-linux-binary.tar + sh $SBCL_DIR/html-distribution.sh sbcl-$VERSION + bzip2 sbcl-$VERSION-documentation-html.tar + + mv $SBCL_DIR/obj/from-xc obj_from-xc_sbcl +fi + +# check build from ccl + +if [ ! -d $SBCL_RELEASE_DIR/obj_from-xc_ccl ]; then + cd $SBCL_DIR + sh clean.sh + nice -20 ./make.sh "$CCL" >> $LOGFILE 2>&1 + cd $SBCL_RELEASE_DIR + + mv $SBCL_DIR/obj/from-xc obj_from-xc_ccl +fi + +# TODO: check binary-equality between ccl, sbcl objs + +# TODO: check build from clisp, abcl + +# upload rc build + +if [ ! -f $SBCL_RELEASE_DIR/uploaded ]; then + + read -n 1 -p "Ok to upload? " A; echo + if [ $A \!= "y" ]; then + exit 1 + fi + + cd $SBCL_RELEASE_DIR +cat > $SBCL_RELEASE_DIR/sftp-batch < ~/.abclrc - - name: build - env: - SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger - run: ./make.sh --xc-host='java -jar abcl.jar' ccl: runs-on: ubuntu-latest + timeout-minutes: 45 steps: - uses: actions/checkout@v1 @@ -85,6 +73,7 @@ cmucl: runs-on: ubuntu-latest + timeout-minutes: 45 steps: - uses: actions/checkout@v1 @@ -94,6 +83,7 @@ cd cmucl wget -q https://github.com/sbcl/sbcl/releases/download/sbcl-1.4.14/cmucl.tar.bz2 tar xf cmucl.tar.bz2 + echo '(setf ext:*gc-verbose* nil)' > ~/.cmucl-init.lisp working-directory: /tmp/ - name: build env: diff -Nru sbcl-2.1.1/.github/workflows/linux.yml sbcl-2.1.11/.github/workflows/linux.yml --- sbcl-2.1.1/.github/workflows/linux.yml 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/.github/workflows/linux.yml 2021-11-30 16:16:46.000000000 +0000 @@ -6,13 +6,15 @@ build: runs-on: ubuntu-latest + timeout-minutes: 60 strategy: matrix: - options: [--with-sb-thread, --without-sb-thread] + options: [--with-sb-thread, --without-sb-thread, --without-sb-unicode] arch: [x86, x86-64] subfeatures: [''] include: - { arch: x86-64, subfeatures: sse4, options: --with-sb-thread } + - { arch: x86-64, subfeatures: fasteval, options: --with-sb-fasteval --without-sb-eval } fail-fast: false @@ -36,5 +38,36 @@ run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger' --arch=${{ matrix.arch }} - name: test run: cd tests; ./run-tests.sh + - name: test + if: matrix.subfeatures == 'fasteval' + run: cd tests; ./run-tests.sh --evaluator-mode interpret - name: ansi-test run: cd tests; ./ansi-tests.sh + + - name: crossbuild arm + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh arm + - name: crossbuild arm64 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh arm64 + - name: crossbuild mips + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh mips + - name: crossbuild ppc + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh ppc + - name: crossbuild ppc64 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh ppc64 + - name: crossbuild riscv + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh riscv + - name: crossbuild sparc + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh sparc + - name: crossbuild x86 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh x86 + - name: crossbuild x86-64 + if: matrix.subfeatures == 'sse4' + run: crossbuild-runner/build-all.sh x86-64 diff -Nru sbcl-2.1.1/.github/workflows/mac.yml sbcl-2.1.11/.github/workflows/mac.yml --- sbcl-2.1.1/.github/workflows/mac.yml 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/.github/workflows/mac.yml 2021-11-30 16:16:46.000000000 +0000 @@ -19,6 +19,21 @@ env: SBCL_MAKE_TARGET_2_OPTIONS: --disable-ldb --disable-debugger run: ./make.sh ${{ matrix.options }} --xc-host='sbcl --dynamic-space-size 500MB --lose-on-corruption --disable-ldb --disable-debugger' + - name: make binary + run: | + name=sbcl-`cat version.lisp-expr | ./run-sbcl.sh --noinform --noprint --eval '(write-line (read))'`-darwin-x86-64 + mkdir sbcl-mac-binary${{ matrix.options }}; + cd .. + mv sbcl $name + ./$name/binary-distribution.sh $name + bzip2 $name-binary.tar + mv $name sbcl + mv $name-binary.tar.bz2 sbcl/sbcl-mac-binary${{ matrix.options }} + - name: save binary + uses: actions/upload-artifact@v1 + with: + name: sbcl-mac-binary${{ matrix.options }} + path: sbcl-mac-binary${{ matrix.options }} - name: test run: cd tests; ./run-tests.sh - name: ansi-test diff -Nru sbcl-2.1.1/.gitignore sbcl-2.1.11/.gitignore --- sbcl-2.1.1/.gitignore 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/.gitignore 2021-11-30 16:16:46.000000000 +0000 @@ -39,6 +39,7 @@ tests/*.so tests/run-tests-* tests/last-random-state.lisp-expr +tests/ansi-test/ tools-for-build/determine-endianness tools-for-build/determine-endianness.exe tools-for-build/grovel-headers diff -Nru sbcl-2.1.1/HACKING sbcl-2.1.11/HACKING --- sbcl-2.1.1/HACKING 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/HACKING 2021-11-30 16:16:46.000000000 +0000 @@ -21,9 +21,6 @@ To change the code at run-time the :SB-DEVEL feature is almost always necessary, otherwise a lot of macros, functions, and variables do not survive in the final image. -"./make-target-2.sh --load-with-sb-devel" can resave the core with -sb-devel without recompiling the whole thing, but probably a better -idea is to put it into customize-target-features.lisp. Patch Submissions ================= @@ -58,7 +55,7 @@ sent to the sbcl-devel mailing list. If you have any questions, feel free to ask them on sbcl-devel, -or the IRC channel #sbcl@freenode.net. +or the IRC channel #sbcl@irc.libera.chat. Coding Style ============ diff -Nru sbcl-2.1.1/INSTALL sbcl-2.1.11/INSTALL --- sbcl-2.1.1/INSTALL 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/INSTALL 2021-11-30 16:16:46.000000000 +0000 @@ -139,11 +139,11 @@ To run the regression tests: - $ cd tests && sh run-tests.sh + $ cd ./tests && sh run-tests.sh To build documentation: - $ cd doc/manual && make + $ cd ./doc/manual && make This builds the Info, HTML and PDF documentation from the Texinfo sources. The manual includes documentation string from the build diff -Nru sbcl-2.1.1/install.sh sbcl-2.1.11/install.sh --- sbcl-2.1.1/install.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/install.sh 2021-11-30 16:16:46.000000000 +0000 @@ -120,12 +120,12 @@ # installing contrib -. ./sbcl-pwd.sh -sbcl_pwd +# See make-target-contrib.sh for this variable. +SBCL_TOP="../../" -SBCL="$SBCL_PWD/src/runtime/sbcl --noinform --core $SBCL_PWD/output/sbcl.core --no-userinit --no-sysinit --disable-debugger" +SBCL="$SBCL_TOP/src/runtime/sbcl --noinform --core $SBCL_TOP/output/sbcl.core --no-userinit --no-sysinit --disable-debugger" SBCL_BUILDING_CONTRIB=1 -export SBCL SBCL_BUILDING_CONTRIB SBCL_PWD +export SBCL SBCL_BUILDING_CONTRIB SBCL_TOP . ./find-gnumake.sh find_gnumake diff -Nru sbcl-2.1.1/make-all-targets.sh sbcl-2.1.11/make-all-targets.sh --- sbcl-2.1.1/make-all-targets.sh 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/make-all-targets.sh 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,11 @@ +#!/bin/sh + +mkdir -p obj/xbuild + +make -k -j9 -f crossbuild-runner/Makefile \ + output/arm.core output/arm64.core \ + output/mips.core \ + output/ppc.core output/ppc64.core \ + output/riscv.core \ + output/sparc.core \ + output/x86.core output/x86-64.core diff -Nru sbcl-2.1.1/make-config.sh sbcl-2.1.11/make-config.sh --- sbcl-2.1.1/make-config.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-config.sh 2021-11-30 16:16:46.000000000 +0000 @@ -562,6 +562,9 @@ printf ' :inode64' >> $ltf fi fi + if [ $sbcl_arch = "arm64" ]; then + printf ' :darwin-jit :gcc-tls' >> $ltf + fi link_or_copy $sbcl_arch-darwin-os.h target-arch-os.h link_or_copy bsd-os.h target-os.h link_or_copy Config.$sbcl_arch-darwin Config @@ -589,8 +592,7 @@ # (Of course it doesn't provide dlopen, but there is # roughly-equivalent magic nevertheless:) printf ' :os-provides-dlopen' >> $ltf - printf ' :sb-thread :sb-safepoint :sb-thruption :sb-wtimer' >> $ltf - printf ' :sb-safepoint-strictly' >> $ltf + printf ' :sb-thread :sb-safepoint' >> $ltf # link_or_copy Config.$sbcl_arch-win32 Config link_or_copy $sbcl_arch-win32-os.h target-arch-os.h @@ -693,8 +695,6 @@ ;; esac -printf ' :linkage-table' >> $ltf - # Use a little C program to try to guess the endianness. Ware # cross-compilers! # diff -Nru sbcl-2.1.1/make-c-runtime.sh sbcl-2.1.11/make-c-runtime.sh --- sbcl-2.1.1/make-c-runtime.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-c-runtime.sh 2021-11-30 16:16:46.000000000 +0000 @@ -12,6 +12,7 @@ (load "src/cold/set-up-cold-packages.lisp") (load "tools-for-build/corefile.lisp") (in-package "SB-COLD") +(defvar *target-sbcl-version* (read-from-file "version.lisp-expr")) (in-host-compilation-mode (lambda (&aux (sb-xc:*features* (cons :c-headers-only sb-xc:*features*))) (do-stems-and-flags (stem flags 1) diff -Nru sbcl-2.1.1/make-host-1.lisp sbcl-2.1.11/make-host-1.lisp --- sbcl-2.1.1/make-host-1.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-host-1.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -3,14 +3,20 @@ (let ((*print-pretty* nil) (*print-length* nil)) (dolist (thing '(("SB-XC" "*FEATURES*") - ("SB-COLD" "*SHEBANG-BACKEND-SUBFEATURES*"))) + ("SB-COLD" "BACKEND-SUBFEATURES"))) (let* ((sym (intern (cadr thing) (car thing))) (val (symbol-value sym))) (when val (format t "~&target ~S = ~S~%" sym val)))))) (in-package "SB-COLD") +#+sbcl +(declaim (sb-ext:muffle-conditions + sb-ext:compiler-note + (satisfies optional+key-style-warning-p))) (progn - (setf *host-obj-prefix* "obj/from-host/") + (setf *host-obj-prefix* (if (boundp 'cl-user::*sbcl-host-obj-prefix*) + (symbol-value 'cl-user::*sbcl-host-obj-prefix*) + "obj/from-host/")) (load "src/cold/set-up-cold-packages.lisp") (load "src/cold/defun-load-or-cload-xcompiler.lisp") @@ -28,30 +34,22 @@ ;; UNDEFINED-VARIABLE does not cause COMPILE-FILE to return warnings-p ;; unless outside a compilation unit. You find out about it only upon ;; exit of SUMMARIZE-COMPILATION-UNIT. So we set up a handler for that. - `(let (in-summary fail) - (handler-bind (((and simple-warning (not style-warning)) - (lambda (c &aux (fc (simple-condition-format-control c))) - ;; hack for PPC. See 'build-order.lisp-expr' - ;; Ignore the warning, and the warning about the warning. - (unless (and (stringp fc) - (or (search "not allowed by the operand type" fc) - (search "ignoring FAILURE-P return" fc))) - (setq fail 'warning)))) - ;; Prevent regressions on a few platforms - ;; that are known to build cleanly. - (sb-int:simple-style-warning - (lambda (c &aux (fc (simple-condition-format-control c))) - (when (and (featurep '(:or :x86 :x86-64 :arm64)) - in-summary - (stringp fc) - (search "undefined" fc)) - (unless (eq fail 'warning) - (setq fail 'style-warning)))))) - (with-compilation-unit () - (multiple-value-prog1 (progn ,@forms) (setq in-summary t)))) - (when fail + `(let (warnp style-warnp) + (handler-bind ((style-warning + ;; Any unmuffled STYLE-WARNING should fail + ;; These would typically be from undefined functions, + ;; or optional-and-key when that was visible. + (lambda (c) + (signal c) ; won't do SETQ if MUFFLE-WARNING is invoked + (setq style-warnp 'style-warning))) + (simple-warning + (lambda (c) + (declare (ignore c)) + (setq warnp 'warning)))) + (with-compilation-unit () ,@forms)) + (when (and (or warnp style-warnp) *fail-on-warnings*) (cerror "Proceed anyway" - "make-host-1 stopped due to unexpected ~A." fail))) + "make-host-1 stopped due to unexpected ~A." (or warnp style-warnp)))) #-(or clisp sbcl) `(with-compilation-unit () ,@forms))) @@ -120,7 +118,16 @@ (setf (gethash input *ucd-inputs*) 'unused)) (dolist (output outputs) (setf (gethash output *ucd-outputs*) 'unmade)) - (let ((object (compile-file "tools-for-build/ucd.lisp"))) + (let ((object (apply #'compile-file "tools-for-build/ucd.lisp" + ;; ECL creates its compiled files beside + ;; the truename of a source; that's bad + ;; when we're in a build tree of symlinks. + #+ecl + (list + :output-file + (compile-file-pathname "tools-for-build/ucd.lisp")) + #-ecl + ()))) (setf (gethash "tools-for-build/ucd.lisp" *ucd-inputs*) 'used) (load object :verbose t) (delete-file object)) @@ -144,12 +151,6 @@ unused-inputs extra-inputs unused-outputs extra-outputs)))))) -;;; I don't know the best combination of OPTIMIZE qualities to produce a correct -;;; and reasonably fast cross-compiler in ECL. At over half an hour to complete -;;; make-host-{1,2}, I don't really want to waste any more time finding out. -;;; These settings work, while the defaults do not. -#+ecl (proclaim '(optimize (safety 2) (debug 2))) - (maybe-with-compilation-unit ;; If make-host-1 is parallelized, it will produce host fasls without loading ;; them. The host will have interpreted definitions of most everything, @@ -161,4 +162,5 @@ (host-cload-stem "src/compiler/generic/genesis" nil) ) ; END with-compilation-unit -(sb-cold:genesis :c-header-dir-name "src/runtime/genesis") +(unless (member :crossbuild-test sb-xc:*features*) + (sb-cold:genesis :c-header-dir-name "src/runtime/genesis")) diff -Nru sbcl-2.1.1/make-host-2.lisp sbcl-2.1.11/make-host-2.lisp --- sbcl-2.1.1/make-host-2.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-host-2.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -28,8 +28,7 @@ (load "src/cold/compile-cold-sbcl.lisp") ;; Enforce absence of unexpected forward-references to warm loaded code. ;; Looking into a hidden detail of this compiler seems fair game. - (when (and sb-c::*undefined-warnings* - (featurep '(:or :x86 :x86-64 :arm64))) ; until all the rest are clean + (when sb-c::*undefined-warnings* (setf fail t) (dolist (warning sb-c::*undefined-warnings*) (case (sb-c::undefined-warning-kind warning) @@ -38,7 +37,7 @@ (:function (setf functions t)))))) ;; Exit the compilation unit so that the summary is printed. Then complain. ;; win32 is not clean - (when (and fail (not (featurep :win32))) + (when (and fail (not (target-featurep :win32))) (cerror "Proceed anyway" "Undefined ~:[~;variables~] ~:[~;types~]~ ~:[~;functions (incomplete SB-COLD::*UNDEFINED-FUN-ALLOWLIST*?)~]" @@ -99,7 +98,7 @@ ;; As each platform's build becomes warning-free, ;; it should be added to the list here to prevent regresssions. (when (and likely-suspicious - (featurep '(:and (:or :x86 :x86-64) (:or :linux :darwin)))) + (target-featurep '(:and (:or :x86 :x86-64) (:or :linux :darwin)))) (warn "Expected zero inlinining failures")))) ;; After cross-compiling, show me a list of types that checkgen diff -Nru sbcl-2.1.1/make.sh sbcl-2.1.11/make.sh --- sbcl-2.1.1/make.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make.sh 2021-11-30 16:16:46.000000000 +0000 @@ -93,11 +93,11 @@ echo "contributed modules. If you would like to run more extensive tests on" echo "the new SBCL, you can try:" echo -echo " cd tests && sh ./run-tests.sh" +echo " cd ./tests && sh ./run-tests.sh" echo echo "To build documentation:" echo -echo " cd doc/manual && make" +echo " cd ./doc/manual && make" echo echo "To install SBCL (more information in INSTALL):" echo diff -Nru sbcl-2.1.1/make-shared-library.sh sbcl-2.1.11/make-shared-library.sh --- sbcl-2.1.1/make-shared-library.sh 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/make-shared-library.sh 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,8 @@ +#!/bin/sh + +. output/build-config + +echo //entering make-shared-library.sh +echo //building sbcl runtime into a shared library + +$GNUMAKE -C src/runtime libsbcl.so diff -Nru sbcl-2.1.1/make-target-1.sh sbcl-2.1.11/make-target-1.sh --- sbcl-2.1.1/make-target-1.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-target-1.sh 2021-11-30 16:16:46.000000000 +0000 @@ -32,15 +32,8 @@ # Build the runtime system and symbol table (.nm) file. # # (This C build has to come after the first genesis in order to get -# the sbcl.h the C build needs, and come before the second genesis in -# order to produce the symbol table file that second genesis needs. It -# could come either before or after running the cross compiler; that -# doesn't matter.) -# -# Note that the latter requirement does not apply to :linkage-table -# builds, since the cross compiler does not depend on symbol tables in -# that case. Only because sbcl.nm is convenient for debugging purposes -# is its generation left enabled even for those builds. +# 'sbcl.h' which the C build. It could come either before or after running +# the cross compiler; that doesn't matter.) echo //building runtime system and symbol table file $GNUMAKE -C src/runtime clean @@ -56,6 +49,5 @@ if [ -n "$SBCL_HOST_LOCATION" ]; then echo //copying target-1 output files to host - rsync -a src/runtime/sbcl.nm "$SBCL_HOST_LOCATION/src/runtime/" rsync -a output/stuff-groveled-from-headers.lisp "$SBCL_HOST_LOCATION/output" fi diff -Nru sbcl-2.1.1/make-target-2-load.lisp sbcl-2.1.11/make-target-2-load.lisp --- sbcl-2.1.1/make-target-2-load.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-target-2-load.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -57,8 +57,8 @@ ;; 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 - :SB-SAFEPOINT :SB-SAFEPOINT-STRICTLY + :MSAN :UBSAN + :SB-SAFEPOINT :SB-THREAD :SB-UNICODE ;; Things which (I think) at least one person has requested be kept around :SB-LDB @@ -70,6 +70,7 @@ :PACKAGE-LOCAL-NICKNAMES ;; Developer mode features. A release build will never have them, ;; hence it makes no difference whether they're public or not. + :METASPACE :SB-FLUID :SB-DEVEL :SB-DEVEL-LOCK-PACKAGES)"))) (removable-features (append non-target-features public-features))) @@ -132,9 +133,9 @@ ;; 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) + (maphash (lambda (classoid wrapper) (when (structure-classoid-p classoid) - (let ((dd (layout-info layout))) + (let ((dd (wrapper-%info wrapper))) (setf (dd-constructors dd) (delete-if (lambda (x) (and (consp x) (uninternable-p (car x)))) @@ -175,7 +176,7 @@ result) ;;; Check for potentially bad format-control strings -(defun !scan-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) @@ -210,12 +211,6 @@ (as the first argument to WARN, etc.) are wrapped in SB-FORMAT:TOKENS")) wps))) -(progn - ;; See the giant comment at the bottom of this file - ;; concerning the need for this GC. - (gc :full t) - (!scan-format-control-strings)) - ;;; Either set some more package docstrings, or remove any and all docstrings ;;; that snuck in (as can happen with any file compiled in warm load) ;;; depending on presence of the :sb-doc internal feature. @@ -253,7 +248,10 @@ :all) ;; 2. Variables, types, and anything else (do-all-symbols (s) - (dolist (category '(:variable :type :typed-structure :setf)) + (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) @@ -322,18 +320,18 @@ ;; Except that symbols which existed at SBCL build time must be. (do-all-symbols (symbol) (when (sb-kernel:immobile-space-obj-p symbol) - (sb-kernel:set-header-data - symbol (logior (sb-kernel:get-header-data symbol) - (ash 1 sb-vm::+initial-core-symbol-bit+))))) + (sb-kernel:logior-header-bits + symbol (ash 1 sb-vm::+initial-core-symbol-bit+)))) ;; 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) - (null (sb-kernel:symbol-info-vector 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))) - (setf (sb-kernel:symbol-info symbol) nil))) + (setf (sb-kernel:symbol-%info symbol) nil))) ) (sb-ext:gc :full t) @@ -398,7 +396,7 @@ #+sb-devel (lambda (symbol accessibility) (declare (ignore accessibility)) - (or (sb-kernel:symbol-info symbol) + (or (sb-kernel:symbol-%info symbol) (and (boundp symbol) (not (keywordp symbol))))) ;; Release mode: retain all symbols satisfying this intricate test #-sb-devel @@ -409,15 +407,13 @@ ;; overapproximate what we need for contribs and tests (member symbol '(sb-vm::map-referencing-objects sb-vm::map-stack-references - sb-vm::thread-profile-data-slot - sb-vm::thread-alloc-region-slot sb-vm::reconstitute-object ;; 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 - sb-vm::thread-control-stack-start-slot)) + #+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-C") @@ -453,7 +449,7 @@ 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) + (or (sb-kernel:symbol-%info symbol) (and (boundp symbol) (not (keywordp symbol)))))))) :verbose nil :print nil) (unintern 'sb-impl::shake-packages 'sb-impl) @@ -474,9 +470,7 @@ sum-delta-ext sum-delta-int (+ sum-delta-ext sum-delta-int)))) -;;; Use historical (stupid) behavior for storing pathname namestrings -;;; in fasls. -(setq sb-c::*name-context-file-path-selector* 'truename) +(scan-format-control-strings) ;;; Lock internal packages #-(and sb-devel diff -Nru sbcl-2.1.1/make-target-2.sh sbcl-2.1.11/make-target-2.sh --- sbcl-2.1.1/make-target-2.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-target-2.sh 2021-11-30 16:16:46.000000000 +0000 @@ -57,13 +57,19 @@ --eval '(sb-fasl::!warm-load "src/cold/warm.lisp")' --quit fi echo //doing warm init - load and dump phase -./src/runtime/sbcl --core output/cold-sbcl.core \ - --lose-on-corruption $SBCL_MAKE_TARGET_2_OPTIONS --no-sysinit --no-userinit \ - --eval "(progn ${devel})" \ - --eval '(sb-fasl::!warm-load "make-target-2-load.lisp")' \ - --eval '(setf (extern-alien "gc_coalesce_string_literals" char) 2)' \ - --eval '(let ((sb-ext:*invoke-debugger-hook* (prog1 sb-ext:*invoke-debugger-hook* (sb-ext:enable-debugger)))) - (sb-ext:save-lisp-and-die "output/sbcl.core"))' +./src/runtime/sbcl --noinform --core output/cold-sbcl.core \ + --lose-on-corruption $SBCL_MAKE_TARGET_2_OPTIONS \ + --no-sysinit --no-userinit --noprint </. Keeping this a relative pathname to the +## toplevel source directory makes the shell and make portions of the +## build system robust against funny stuff in PWD. +SBCL_TOP="../../" -SBCL_HOME="$SBCL_PWD/obj/sbcl-home" -export SBCL_HOME SBCL_PWD -if [ "$OSTYPE" = "cygwin" ] ; then - SBCL_PWD=`echo $SBCL_PWD | sed s/\ /\\\\\\\\\ /g` -fi +SBCL_HOME="$SBCL_TOP/obj/sbcl-home" +export SBCL_HOME SBCL_TOP -SBCL="$SBCL_PWD/src/runtime/sbcl --noinform --core $SBCL_PWD/output/sbcl.core \ +SBCL="$SBCL_TOP/src/runtime/sbcl --noinform --core $SBCL_TOP/output/sbcl.core \ --lose-on-corruption --disable-debugger --no-sysinit --no-userinit" SBCL_BUILDING_CONTRIB=1 export SBCL SBCL_BUILDING_CONTRIB @@ -72,7 +73,7 @@ # Otherwise report expected failures: HEADER_HAS_BEEN_PRINTED=false -for dir in `cd obj/asdf-cache/ ; echo *`; do +for dir in `cd ./obj/asdf-cache/ ; echo *`; do f="obj/asdf-cache/$dir/test-passed.test-report" if test -f "$f" && grep -i fail "$f" >/dev/null; then if ! $HEADER_HAS_BEEN_PRINTED; then @@ -89,7 +90,7 @@ done if [ -z "$*" ]; then - contribs_to_build="`cd contrib ; echo *`" + contribs_to_build="`cd ./contrib ; echo *`" else contribs_to_build="$*" fi diff -Nru sbcl-2.1.1/make-windows-installer.sh sbcl-2.1.11/make-windows-installer.sh --- sbcl-2.1.1/make-windows-installer.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/make-windows-installer.sh 2021-11-30 16:16:46.000000000 +0000 @@ -11,12 +11,10 @@ WIX_PATH=$WIX/bin -. ./sbcl-pwd.sh -sbcl_pwd +SBCL_TOP=../ +cd ./output -cd output - -"$SBCL_PWD/src/runtime/sbcl" --noinform --core "$SBCL_PWD/output/sbcl.core" \ +"$SBCL_TOP/src/runtime/sbcl" --noinform --core "$SBCL_TOP/output/sbcl.core" \ --disable-debugger --no-sysinit --no-userinit \ --load ../tools-for-build/rtf.lisp \ --load ../tools-for-build/wxs.lisp \ diff -Nru sbcl-2.1.1/NEWS sbcl-2.1.11/NEWS --- sbcl-2.1.1/NEWS 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/NEWS 2021-11-30 16:16:46.000000000 +0000 @@ -1,5 +1,252 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes in sbcl-2.1.11 relative to sbcl-2.1.10: + * minor incompatible change: *COMPILE-PRINT* now defaults to NIL. T gives + the old behavior of echoing top level forms. Users who want to see a + report of the phases of compilation can use *COMPILE-PROGRESS* and the + corresponding COMPILE-FILE :PROGRESS argument. + * optimization: The compiler assignment-converts functions much more + aggressively; local or non-entry block-compiled functions + which always return to the same place are automatically converted into the + equivalent loop or goto control structures. + * enhancement: on x86-64 and ppc64 platforms, the system uses inline + instructions rather than page protection to implement a store barrier for + the garbage collector. + * enhancement: improved reporting of code deletion notes. + * platform support: + ** unbound-variable restarts for amd64 are now supported. + ** bug fix: single-floats to foreign functions on 32-bit ARMel. + (lp#1950080, reported by Sebastien Villemot) + ** bug fix: opening files with names containing non-ASCII characters on + Windows works better. (reported by Nikolay) + ** bug fix: use fp_xsave to access the floating point flags and control + word in Haiku signal contexts. (Thanks to Al Hoang) + ** bug fix: complex single-float support on riscv64. + ** optimization: support for accessing elements of &rest args directly on + ppc64, mips, riscv. + ** optimization: parse a /proc file rather than executing uname for + SOFTWARE-VERSION on Linux + * bug fix: fix crash from SB-COVER:RESET-COVERAGE. (lp#1950059, reported by + Gregory Czerniak) + +changes in sbcl-2.1.10 relative to sbcl-2.1.9: + * incompatible change: simd-pack without a specific element-type is no + longer treated as containing integers. A type must be supplied for VOPs to + work on such values. + * minor incompatible change: the list form of the FUNCTION type specifier + does not allow * as any argument type, but does allow * as a placeholder + for wholly unspecified arguments when specifying the value(s) type. + * minor incompatible change: the default (Lisp) toplevel option parser + throws an error if it encounters an option which was intended to be used + and removed by the C runtime. (lp#1945081, reported by Luke Gorrie) + * new feature: there is now a defined interface for defining foreign + callable functions, which can be used for passing callbacks to foreign + functions or for calling Lisp code from the foreign world as a shared + library (preliminary support). See the revised manual section "Calling + into Lisp From C" for more details. + * enhancement: arg-count mismatches in self-calls in defmethod are reported. + (lp#1912436, reported by 3b) + * enhancement: the SB-CLTL2 contrib now returns type information for + generated structure accessors. (lp#1934859, reported by SATO shinichi) + * optimization: code generation is improved for modular arithmetic involving + signed operations. + * platform support: + ** x86-64 machine code emitter crash when attempting to assemble some + vector instructions. (lp#1945975, thanks to Marco Heisig) + ** conditional move instructions are now supported on arm64. + ** a number of new peephole optimizations have been implemented on arm64. + ** arm64 on Darwin now uses gcc-compatible thread-local storage. + * bug fix: compiler notes are no longer emitted when compiling FORMATTER + forms, including when implicitly triggered on a constant string argument + to FORMAT. (lp#1946246, reported by SATO shinichi) + * bug fix: a compiler error when attempting to compile a call to AREF with + too many dimensions. (lp#1902985) + * bug fix: harmonize the behaviour of SLOT-BOUNDP on non-standard-objects + between the various ways in which it can be called. (lp#732229, reported + by Zach Beane) + * bug fix: FTRUNCATE and similar functions are now more careful about + deriving facts about the sign of zero they might return. (lp#1732009, + reported by Paul Dietz) + +changes in sbcl-2.1.9 relative to sbcl-2.1.8: + * minor incompatible change: the experimental DEFCAS macro has been removed. + * minor incompatible change: finalizing classes with slots with duplicate + symbol-names will only emit a warning if either slot name is an exported + symbol. (lp#1943559) + * platform support: + ** the debugger is better able to display SIMD packs. (thanks to Marco + Heisig) + ** fix a bug in zeroing YMM registers. (thanks to Marco Heisig) + ** fix instruction definitions for SSE blend and shuffle vector + instructions. (thanks to Marco Heisig) + ** handle heap corruption exceptions in our exception handler on win64. + ** improve WAIT-UNTIL-FD-USABLE on Windows, reducing busy-looping. + (thanks to Fabio Almeida) + * bug fix: EQUALP hash tables whose keys contain arrays containing floats should + behave correctly. (lp#1942424, reported by Nicolas Neuss) + +changes in sbcl-2.1.8 relative to sbcl-2.1.7: + * minor incompatible change: the experimental DEFINE-CAS-EXPANDER macro has + been removed. + * minor incompatible change: the hooks in *INIT-HOOKS* are called before + starting the finalizer or other non-user threads. (thanks to Sean Whitton) + * platform support: + ** many improvements to code generation on arm64. + ** avoid slow forms of the bit test instructions BT, BTS, BTR on x86-64. + ** fix a bug in loading large core files on the Apple M1/arm64. (thanks + to Mayank Manjrekar) + ** fix a bug in loading core loading on the Apple M1/arm64. (reported by + Eric Timmons) + * enhancement: the block-compiler is more robust to files with intermingled + compile-time and load-time effects. The semantics of the block-compiler + remain not-entirely ANSI compatible. (thanks to Sean Maher) + * enhancement: (CAS SAP-REF-) and CAS on alien integers is implemented on + ppc64 and x86-64, working towards fixing lp#1894057 + * bug fix: fix OPEN-STREAM-P on streams closed by saving a core. + (lp#1938433, reported by Guillaume LE VAILLANT) + * bug fix: remove a spurious warning from COERCE. (lp#1920931, reported by + Andrew Berkley) + * bug fix: remove a warning from inlining SET-EXCLUSIVE-OR. (lp#1936470, + reported by Jerome Abela) + +changes in sbcl-2.1.7 relative to sbcl-2.1.6: + * incompatible change: on certain platforms (currently just x86-64), + dynamic-extent arrays specialized on character and numeric types and + created without either :INITIAL-ELEMENT or :INITIAL-CONTENTS will reflect + previous contents of the stack instead of #\null (or 0) in all elements. + * minor incompatible change: SB-SPROF:START-PROFILING no longer silently + does nothing if the clock is already running. It instead stop and restarts + with the newly provided options, and warns. + * minor incompatible change: the system attempts to refer to the supplied + pathname in compiler diagnostics, if relevant, rather than the truename. + * enhancement: new contrib module sb-graph producing graphical + visualizations of Intermediate Representations of SBCL compilation data + structures. + * platform support: + ** improved code generation for unary minus in modular contexts on arm64. + ** make the disassembler annotations slightly more robust on arm64. + ** release space back to the Operating System on Windows. + ** improve the test for whether pages need to be committed on Windows. + * optimization: the type of (LOOP ... COLLECT ...), and the type of COLLECT + INTO variables, is derived as LIST. (lp#1934577, reported by SATO + shinichi) + +changes in sbcl-2.1.6 relative to sbcl-2.1.5: + * minor incompatible change: COMPILE-FILE does not merge the input file's + pathname-directory into the output path if :OUTPUT-FILE was specified + and has a directory that is not :UNSPECIFIC. + * platform support: + ** improvements to unwind code generation on arm64. + ** on x86-64, accept three operands for vshufpd. (reported by Bela + Pecsek) + ** on x86-64, improvements to use of popcount + ** improve exception handling on 64-bit Windows. (thanks to Luis Borges + de Oliveira) + * bug fix: allow use of macros with improper argument list. (lp#1929623, + thanks to Sean Maher) + * bug fix: COERCE no longer attempts to guess what the user meant if they + provide a type specifier of a union of types other than STRING. + (lp#1929614) + * bug fix: print a single trailing zero after the decimal point for FORMAT + ~E if there are no digits remaining to be printed and the width allows it. + (lp#883520) + +changes in sbcl-2.1.5 relative to sbcl-2.1.4: + * minor incompatible change: on x86-64, the backend instruction encoders for + movzx and for string opcodes have changed their semantics. + * platform support: + ** compatibility: support the latest MinGW on x86. (lp#1923325, thanks to + Alexis Rivera) + ** bug fix: on x86-64, fix instruction encoding for TEST on RIP-relative + addresses. (lp#1925808, reported by Shinmera on #sbcl, thanks also to + 3b) + ** bug fix: on x86-64, loading all-1s into an AVX2 register no longer + causes an error. (lp#1928516, thanks to Marco Heisig) + ** bug fix: on arm64, improve disassembly of ADD with constant 0 as MOV + ** enhancement: on arm64, support debugger commands RETURN-FROM-FRAME and + RESTART-FRAME more efficiently. + ** enhancement: on x86-64, add support for vshuf* AVX2 instructions. + (reported by Bela Pecsek) + ** optimization: faster function calls on arm64. + ** optimization: (SETF SBIT) is faster on x86-64. + * bug fix: INTEGER-DECODE-FLOAT was computing the wrong answer for denormal + double floats. (lp#1926383, reported by Stavros Macrakis) + * bug fix: RANDOM on a floating point argument now does not cons. (reported + by Tito Latini) + * bug fix: fix a compiler crash in type derivation of LOGTEST. (lp#1928243) + * bug fix: fix a compiler failure when a declared function type contains a + literal structure with a valid MAKE-LOAD-FORM method. (lp#1929160, thanks + to Yurii Hryhorenko) + * optimization: FBOUNDP on a constant symbol is now faster. + * optimization: file compilation now produces smaller fasls for files which + reference package literals. + * optimization: derive the type of calls to FLOAT-SIGN. + +changes in sbcl-2.1.4 relative to sbcl-2.1.3: + * platform support: + ** work around address-space randomization causing instability on new + versions of MinGW. (lp#1921141) + * bug fix: RANDOM on floats returns values strictly less than the float + argument. + * bug fix: compiler error on x86-64 resulting from attempting to zero a + memory location with xor. (reported by Eric Marsden) + * optimization: extended loops updating iteration variables with THEN can + perform specialized arithmetic for those updates. + * optimization: in some cases, the jump table resulting from a compilation + of TYPECASE is simpler. + * optimization: on x86-64, IF BOUNDP followed by SYMBOL-VALUE can elide some + memory loads and tests. + +changes in sbcl-2.1.3 relative to sbcl-2.1.2: + * minor incompatible change: support for the :SB-SAFEPOINT-STRICTLY, + :SB-THRUPTION, and :SB-WTIMER build features has been removed + * platform support: + ** support for :SB-CORE-COMPRESSION on Darwin/ARM64 + ** support ARM v8.1 atomic and compare-and-swap instructions + ** x86, x86-64: microoptimizations in multiple type-checking routines + * bug fix: structures and conditions are now TYPEP all classes in the class + precedence list of their class. (reported by Luis Oliveira) + * bug fix: derivation of the result type from subtraction sometimes + erroneously excluded zero. (lp#1916895) + * bug fix: reduce the number of places where the system permissively accepts + the symbol * as a type specifier where it should not be accepted. + (lp#1860919) + * bug fix: the code-walker used by the system's implementation of CLOS can + handle defuns declared inline. (reported by Don Cohen) + * optimization: EQUALP on specialized vectors and arrays is faster. + * optimization: support routines for EQUALP hash tables generate less garbage. + +changes in sbcl-2.1.2 relative to sbcl-2.1.1: + * platform support: + ** support for ARM64 macOS; + ** improvement in coverage mark implementation on non-x86oid backends, + approaching the existing x86oid support; + ** more empirically-robust retrieval of the program counter from illegal + instruction traps on SPARC; + ** retain fewer dead objects when saving cores with precise collectors. + * incompatible change: MAP-ALL-SAMPLES and MAP-TRACE-SAMPLES + are no longer present in the SB-SPROF contrib module. + * minor incompatible change: SB-SPROF:WITH-PROFILING defaults to all + threads. SB-SPROF:START-PROFILING no longer accepts a :SAMPLING keyword. + * enhancement: the sb-introspect contrib now supports finding the lambda + lists of method combinations. (thanks to Didier Verna) + * enhancement: short-form DEFSETF now stores a source-location. + * bug fix: canonical unions of CONS types were being incorrectly computed. + (lp#1912863, reported by James Kalenius) + * bug fix: better understanding of array simplicity (or otherwise) in the + type system. (lp#1903241) + * bug fix: unions of rational and integer types now have a single canonical + form, allowing more correct reasoning about them in the type system. + * bug fix: less likely to overclaim certainty about type equality of union + types. (lp#1916040) + * bug fix: HANDLER-BIND evaluates the forms producing handler functions only + once. (lp#1916302, reported by Christophe Junke) + * optimization: FIND on constant sequences can be compiled into a jump + table, in a similar manner to POSITION + * optimization: the compiler's awareness of numeric contagion rules for + operations on pairs of floating point numbers is improved. (lp#1914094, + thanks to Andrew Berkley) + changes in sbcl-2.1.1 relative to sbcl-2.1.0: * platform support: ** restore non-threaded NetBSD builds; @@ -9,7 +256,7 @@ object being iterated over is known not to be a list. (lp#1908819, reported by Michael Fiano) * bug fix: detect 2 or 1 as an invalid number of arguments passed to - optimized slot writing or reading effective method respectively. + optimized slot reading or writing effective method respectively. (lp#1909659, reported by Michal Herda) * bug fix: division by zero errors were in some cases not being signalled. (lp#1910098, reported by il71) diff -Nru sbcl-2.1.1/package-data-list.lisp-expr sbcl-2.1.11/package-data-list.lisp-expr --- sbcl-2.1.1/package-data-list.lisp-expr 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/package-data-list.lisp-expr 1970-01-01 00:00:00.000000000 +0000 @@ -1,3584 +0,0 @@ -;;;; -*- Lisp -*- - -;;;; the specifications of target packages, except for a few things -;;;; which are handled elsewhere by other mechanisms: -;;;; * some SHADOWing and nickname hackery; -;;;; * the standard, non-SBCL-specific packages COMMON-LISP, -;;;; COMMON-LISP-USER, and KEYWORD. -;;;; - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -;;;; KLUDGE: To make it easier for emacs to autoindent this file nicely -;;;; (which prevents spurious conflicts in CVS) each longish list should -;;;; have only one string on the first line. Silly, but there you go. - -;;;; NOTE: -;;;; All uses of #+ and #- reader macros within this file refer to -;;;; the chosen target features, and not CL:*FEATURES*, but -;;;; it is generally not necessary to use reader conditionals -;;;; within this file. If A-NICE-FUNCTION is external in SB-KERNEL -;;;; but not defined for a particular backend, it will not get -;;;; interned during cold load, and hence will not exist in the target. -;;;; This is exactly as desired - it is not necessary for the writer -;;;; of architecture-specific code to clutter up the list of package -;;;; definitions to avoid exporting some stuff. You just export what you -;;;; need, and genesis will do the right thing. Most of the pre-existing -;;;; conditionals are historical baggage, and should be removed. -;;;; EXCEPTION: packages whose symbols are created mainly during -;;;; warm load might have a reason to use reader conditionals. -;;;; For those packages, all symbols listed here are interned during -;;;; genesis, since otherwise the symbols would all disappear, -;;;; and then warm load would intern them as internals, not externals. -;;;; This list of exceptional packages can be found in the -;;;; definition of the FINISH-SYMBOLS function. - -(#s(sb-cold:package-data - :name "SB-ALIEN" - :doc "public: the ALIEN foreign function interface (If you're -porting CMU CL code, note that this package corresponds roughly to a union -of the packages ALIEN and C-CALL at the time of the SBCL fork. SB-C-CALL -is a deprecated nickname to help ease the transition from older versions -of SBCL which maintained the CMU-CL-style split into two packages.)" - :use ("CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-ALIEN-INTERNALS") - :reexport ("ARRAY" - "BOOLEAN" "CHAR" "DOUBLE-FLOAT" - "FLOAT" "FUNCTION" "INTEGER" "LONG-FLOAT" - "SINGLE-FLOAT" - ;; FIXME: Do we really want to reexport - ;; SYSTEM-AREA-POINTER here? Why? - "SYSTEM-AREA-POINTER" - "UNION" "VALUES" "*") - :export ("ADDR" - "ALIEN" - "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" - "CAST" "C-STRING" - "DEFINE-ALIEN-ROUTINE" "DEFINE-ALIEN-TYPE" "DEFINE-ALIEN-VARIABLE" - "DEREF" "DOUBLE" - "ENUM" "EXTERN-ALIEN" - "FREE-ALIEN" - "GET-ERRNO" - "INT" - "LOAD-1-FOREIGN" "LOAD-FOREIGN" "LOAD-SHARED-OBJECT" "LONG" "LONG-LONG" - "MAKE-ALIEN" - "MAKE-ALIEN-STRING" - "NULL-ALIEN" - "OFF-T" - "SAP-ALIEN" "SHORT" "SIGNED" - "SIZE-T" "SSIZE-T" - "SLOT" "STRUCT" - "UNDEFINED-ALIEN-ERROR" - "UNLOAD-SHARED-OBJECT" - "UNSIGNED" - "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-LONG-LONG" "UNSIGNED-SHORT" - "UTF8-STRING" - "VOID" - "WITH-ALIEN")) - - #s(sb-cold:package-data - :name "SB-ALIEN-INTERNALS" - :doc "private: stuff for implementing ALIENs and friends" - :use ("CL") - :export ("%ALIEN-VALUE" - "%CAST" - "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" - "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" - "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" - "%SLOT-ADDR" "*SAVED-FP*" "*VALUES-TYPE-OKAY*" - "ALIEN-ARRAY-TYPE" - "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" - "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" - "ALIEN-CALLBACK" - "ALIEN-CALLBACK-ACCESSOR-FORM" - "ALIEN-CALLBACK-ASSEMBLER-WRAPPER" - "ALIEN-DOUBLE-FLOAT-TYPE" "ALIEN-DOUBLE-FLOAT-TYPE-P" - "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FLOAT-TYPE" - "ALIEN-FLOAT-TYPE-P" "ALIEN-FUN-TYPE" - "ALIEN-FUN-TYPE-ARG-TYPES" "ALIEN-FUN-TYPE-P" - "ALIEN-FUN-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE" - "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED" - "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P" - "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P" - "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD" - "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET" - "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE" - "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS" - "ALIEN-RECORD-TYPE-P" "ALIEN-SINGLE-FLOAT-TYPE" - "ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE" - "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS" - "ALIEN-TYPE-P" "ALIEN-TYPEP" - "ALIEN-VALUE" - "ALIEN-VALUE-TYPE" - "ALIEN-VALUE-TYPEP" - "ALIEN-VALUE-SAP" "ALIEN-VALUE-P" - "ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P" - "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "ALIEN-VOID-TYPE-P" - "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-ALLOC-LAMBDA" - "COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA" - "COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE" - "COMPUTE-NATURALIZE-LAMBDA" "DEFINE-ALIEN-TYPE-CLASS" - "DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR" - "DEPORT" "DEPORT-ALLOC" - "ENTER-ALIEN-CALLBACK" - "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" - "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" - "INVOKE-WITH-SAVED-FP" "LOCAL-ALIEN" - "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" - "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE" - "MAKE-ALIEN-FUN-TYPE" "MAKE-ALIEN-POINTER-TYPE" - "MAYBE-WITH-PINNED-OBJECTS" - "MAKE-LOCAL-ALIEN" "NATURALIZE" - "NOTE-LOCAL-ALIEN-TYPE" - "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE")) - - #s(sb-cold:package-data - :name "SB-ASSEM" - :doc "private: the assembler, used by the compiler" - :use ("CL" "SB-EXT" "SB-INT") - :export ("ASSEMBLY-UNIT" - "ASSEMBLY-UNIT-BITS" - "+INST-ALIGNMENT-BYTES+" - - "ASSEM-SCHEDULER-P" - "+ASSEM-MAX-LOCATIONS+" - - "*ASMSTREAM*" "MAKE-ASMSTREAM" - "ASMSTREAM-DATA-SECTION" - "ASMSTREAM-CODE-SECTION" - "ASMSTREAM-ELSEWHERE-SECTION" - "ASMSTREAM-ELSEWHERE-LABEL" - "ASMSTREAM-CONSTANT-TABLE" - "ASMSTREAM-CONSTANT-VECTOR" - "APPEND-SECTIONS" "ASSEMBLE-SECTIONS" - "EMIT" ".ALIGN" ".BYTE" ".LISPWORD" ".SKIP" - ".COVERAGE-MARK" ".COMMENT" - "EMIT-ALIGNMENT" "EMIT-BYTE" "EMIT-BACK-PATCH" - "EMIT-CHOOSER" "DEFINE-BITFIELD-EMITTER" - "DEFINE-INSTRUCTION" "DEFINE-INSTRUCTION-MACRO" - "EMIT-POSTIT" - "ANY-ALIGNMENT-BETWEEN-P" - - "MAKE-SEGMENT" "SEGMENT-ORIGIN" "ASSEMBLE" - "SEGMENT-BUFFER" - "SEGMENT-ENCODER-STATE" - "SEGMENT-HEADER-SKEW" - "INST" "INST*" "LABEL" "LABEL-P" "GEN-LABEL" - "EMIT-LABEL" "LABEL-POSITION" "LABEL-USEDP" - "FINALIZE-SEGMENT" - "SEGMENT-CONTENTS-AS-VECTOR" "WRITE-SEGMENT-CONTENTS" - "READS" "WRITES" "SEGMENT" - "WITHOUT-SCHEDULING" - "VARIABLE-LENGTH" - "SEGMENT-COLLECT-DYNAMIC-STATISTICS" - "SECTION-START" - "STMT-LABELS" "STMT-MNEMONIC" "STMT-OPERANDS" - "STMT-PLIST" - "STMT-PREV" "STMT-NEXT" - "ADD-STMT-LABELS" "DELETE-STMT" - "LABELED-STATEMENT-P" - "DEFPATTERN" - - ;; FIXME: These are in the SB-ASSEM package now, but - ;; (left over from CMU CL) are defined in files which - ;; are IN-PACKAGE SB-C. It would probably be cleaner - ;; to move at least most of them to files which are - ;; IN-PACKAGE SB-ASSEM. - "BRANCH" "FLUSHABLE")) - - #s(sb-cold:package-data - :name "SB-BIGNUM" - :doc "private: bignum implementation" - :use ("CL" "SB-KERNEL" "SB-INT" "SB-EXT") - :export ("%ADD-WITH-CARRY" - "%ALLOCATE-BIGNUM" "%ASHL" "%ASHR" - "%BIGNUM-LENGTH" "%BIGNUM-REF" "%BIGNUM-REF-WITH-OFFSET" - "%BIGNUM-SET" - "%BIGNUM-SET-LENGTH" "%DIGIT-0-OR-PLUSP" - "%DIGIT-LOGICAL-SHIFT-RIGHT" - "%FIXNUM-DIGIT-WITH-CORRECT-SIGN" "%FIXNUM-TO-DIGIT" - "%BIGFLOOR" "%LOGAND" "%LOGIOR" "%LOGNOT" "%LOGXOR" - "%MULTIPLY" "%MULTIPLY-AND-ADD" - "%SUBTRACT-WITH-BORROW" "ADD-BIGNUMS" - "BIGNUM-ASHIFT-LEFT" "BIGNUM-ASHIFT-LEFT-FIXNUM" - "BIGNUM-ASHIFT-RIGHT" - "BIGNUM-COMPARE" - "BIGNUM-ELEMENT-TYPE" "BIGNUM-GCD" "BIGNUM-INDEX" - "BIGNUM-LENGTH" - "BIGNUM-INTEGER-LENGTH" - "BIGNUM-LOGBITP" - "BIGNUM-LOGCOUNT" "BIGNUM-LOGICAL-AND" - "BIGNUM-LOGICAL-IOR" "BIGNUM-LOGICAL-NOT" - "BIGNUM-LOGICAL-XOR" "BIGNUM-PLUS-P" - "BIGNUM-TO-FLOAT" "BIGNUM-TRUNCATE" - "MAKE-SMALL-BIGNUM" - "MULTIPLY-BIGNUM-AND-FIXNUM" "MULTIPLY-BIGNUMS" - "MULTIPLY-FIXNUMS" "NEGATE-BIGNUM" - "%RANDOM-BIGNUM" "SUBTRACT-BIGNUM" "SXHASH-BIGNUM")) - - #s(sb-cold:package-data - :name "SB-C" - :doc "private: implementation of the compiler" - ;; (It seems strange to have the compiler USE SB-ALIEN-INTERNALS, - ;; but the point seems to be to be able to express things like - ;; SB-C:DEFTRANSFORM SB-ALIEN-INTERNALS:MAKE-LOCAL-ALIEN without - ;; having to use a bunch of package prefixes, by putting them - ;; in the SB-C package. Maybe it'd be tidier to define an SB-ALIEN-COMP - ;; package for this? But it seems like a fairly low priority.) - ;; (Probably the same considerations also explain why BIGNUM is - ;;in the USE list.) - :use ("CL" "SB-ALIEN-INTERNALS" "SB-ALIEN" "SB-ASSEM" "SB-BIGNUM" - #+sb-dyncount "SB-DYNCOUNT" "SB-EXT" "SB-FASL" "SB-INT" - "SB-KERNEL" "SB-SYS") - ;; "flushable" is an assembly instruction attribute and a fun-info attribute. - ;; But why do we need SLOT re-exported? - :reexport ("SLOT" "FLUSHABLE") - :export ("%ALIEN-FUNCALL" - "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "%UNWIND" - "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" - "%UNWIND-PROTECT-BREAKUP" - - "*BACKEND-BYTE-ORDER*" "*BACKEND-DISASSEM-PARAMS*" - "+BACKEND-INTERNAL-ERRORS+" "+BACKEND-PAGE-BYTES+" - "*BACKEND-REGISTER-SAVE-PENALTY*" - "*BACKEND-SBS*" ; storage bases - "*BACKEND-SC-NAMES*" "*BACKEND-SC-NUMBERS*" - "*BACKEND-SUBFEATURES*" - "*BACKEND-T-PRIMITIVE-TYPE*" - - "*COMPILATION*" - "*COMPILE-TO-MEMORY-SPACE*" - "*ELSEWHERE*" - "*LEXENV*" - "*SUPPRESS-VALUES-DECLARATION*" - - #+x86 "SET-FPU-WORD-FOR-C" - #+x86 "SET-FPU-WORD-FOR-LISP" - "ALIGN-STACK-POINTER" - "ALIEN-FUNCALL-SAVES-FP-AND-PC" - "ALLOC-ALIEN-STACK-SPACE" "ALLOC-NUMBER-STACK-SPACE" - "ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME" - "ALLOCATE-FULL-CALL-FRAME" - "ALWAYS-TRANSLATABLE" - "ANCESTOR-FRAME-REF" "ANCESTOR-FRAME-SET" - "ANY" "ARG-COUNT-ERROR" "ASSEMBLE-FILE" - "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION" - "ATTRIBUTES=" - "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-VARIABLE" - "CALL-OUT" "CALL-OUT-NAMED" - "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN" - "CASE-BODY" "CATCH-BLOCK" "UNWIND-BLOCK" - "CLOSURE-INIT" "CLOSURE-REF" "CLOSURE-INIT-FROM-FP" - "COMPARE-AND-SWAP-SLOT" - "COMPILE-IN-LEXENV" - "COMPILED-DEBUG-FUN-FORM-NUMBER" - "%COMPILER-DEFUN" "COMPILER-ERROR" "FATAL-COMPILER-ERROR" - "COMPILER-NOTIFY" - "COMPILER-STYLE-WARN" "COMPILER-WARN" - "COMPONENT" "COMPONENT-HEADER-LENGTH" - "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUN" - "COMPUTE-OLD-NFP" "COPY-MORE-ARG" - "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" - "CURRENT-STACK-POINTER" - "*ALIEN-STACK-POINTER*" - "CURRENT-NSP" "SET-NSP" - "DEALLOC-ALIEN-STACK-SPACE" - "DEALLOC-NUMBER-STACK-SPACE" - "DEBUG-CATCH-TAG" - "DEF-IR1-TRANSLATOR" - "!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS" - "DEFINE-SOURCE-TRANSFORM" - "DEFINITION-SOURCE-LOCATION" - "DEFINITION-SOURCE-LOCATION-NAMESTRING" - "DEFINITION-SOURCE-LOCATION-TOPLEVEL-FORM-NUMBER" - "DEFINITION-SOURCE-LOCATION-FORM-NUMBER" - "DEFINITION-SOURCE-LOCATION-PLIST" - "DEFINE-MODULAR-FUN" - "DEFINE-MOVE-FUN" - "DEFINE-MOVE-VOP" "!DEFINE-STORAGE-BASES" - "!DEFINE-STORAGE-CLASS" "DEFINE-VOP" - "DEFKNOWN" "DEFOPTIMIZER" - "DEFTRANSFORM" "DERIVE-TYPE" - "DIS" - "DO-FORMS-FROM-INFO" - "EMIT-BLOCK-HEADER" - "PHYSENV-DEBUG-LIVE-TN" "PHYSENV-LIVE-TN" - "FAST-SYMBOL-VALUE" - "FAST-SYMBOL-GLOBAL-VALUE" - "FIXUP-NOTE-KIND" - "FIXUP-NOTE-FIXUP" - "FIXUP-NOTE-POSITION" - "FOLDABLE" - "FORCE-TN-TO-STACK" - "FUN-INFO-DERIVE-TYPE" "FUN-INFO-IR2-CONVERT" - "FUN-INFO-LTN-ANNOTATE" "FUN-INFO-OPTIMIZER" - "GET-TOPLEVELISH-FILE-INFO" - "HALT" - "IF-EQ" - "CONSTANT-TN-P" - "INSERT-SAFEPOINTS" - "COMPILER-MACRO-APPLICATION-MISSED-WARNING" - "INLINING-DEPENDENCY-FAILURE" - "INSERT-STEP-CONDITIONS" - "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" - "IR2-PHYSENV-NUMBER-STACK-P" - "KNOWN-CALL-LOCAL" "KNOWN-RETURN" - "LAMBDA-VAR-IGNOREP" - "LAMBDA-WITH-LEXENV" "LEXENV-FIND" - "LOCATION=" "LTN-ANNOTATE" - "MACRO-POLICY-DECLS" - "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK" - "MAKE-CLOSURE" "MAKE-CONSTANT-TN" - "MAKE-FIXUP-NOTE" - "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN" - "MAKE-RANDOM-TN" - "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" - "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK" - "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTIFY" - "MAYBE-INLINE-SYNTACTIC-CLOSURE" - "MSAN-UNPOISON" - "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL" - "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED" - "MULTIPLE-CALL-VARIABLE" - "%%NIP-DX" "%%NIP-VALUES" - "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" - "NODE-STACK-ALLOCATE-P" - "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" - "NOTE-THIS-LOCATION" "*LOCATION-CONTEXT*" - "MAKE-RESTART-LOCATION" - "OPTIMIZER" - "PACK-CODE-FIXUP-LOCS" - "PARSE-EVAL-WHEN-SITUATIONS" - "POLICY" - "%%POP-DX" - "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF" - "PRIMITIVE-TYPE-OR-LOSE" - "PRIMITIVE-TYPE-NAME" - "PRIMITIVE-TYPE-INDIRECT-CELL-TYPE" - "PROCLAIM-FTYPE" "PROCLAIM-TYPE" - "PUSH-VALUES" - "READ-PACKED-BIT-VECTOR" - "READ-VAR-INTEGER" "READ-VAR-INTEGERF" - "SAP-READ-VAR-INTEGER" "SAP-READ-VAR-INTEGERF" - "READ-VAR-STRING" - "REGISTER-INLINE-CONSTANT" - "RESET-STACK-POINTER" "RESTORE-DYNAMIC-STATE" - "RETURN-MULTIPLE" "SAVE-DYNAMIC-STATE" "STORAGE-BASE" - "SB-ALLOCATED-SIZE" "SB-NAME" "SB-OR-LOSE" - "STORAGE-CLASS" "SC-CASE" "SC-OPERAND-SIZE" - "SC-IS" "SC-NAME" "SC-NUMBER" "SC-SB" - "SC-OR-LOSE" "SC-NUMBER-OR-LOSE" - "SC+OFFSET" "MAKE-SC+OFFSET" "SC+OFFSET-OFFSET" "SC+OFFSET-SCN" - "SET-UNWIND-PROTECT" - "SETUP-CLOSURE-ENVIRONMENT" - "SOURCE-LOCATION" - "SPECIFY-SAVE-TN" - "STATIC-CALL-NAMED" "STATIC-MULTIPLE-CALL-NAMED" "STATIC-TAIL-CALL-NAMED" - "STORE-COVERAGE-DATA" "STORE-SOURCE-FORM" - "TAIL-CALL" "TAIL-CALL-NAMED" - "TAIL-CALL-VARIABLE" "TEMPLATE-OR-LOSE" - "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" - "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" - "TN-REF-TN" "TN-REF-TYPE" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" - "TN-REF-MEMORY-ACCESS" - "TN-KIND" "TN-VALUE" - "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-N" "UNBIND-TO-HERE" - "UNSAFE" "UNSAFELY-FLUSHABLE" "UNWIND" "UWP-ENTRY" - "UNPACK-CODE-FIXUP-LOCS" - "VERIFY-ARG-COUNT" "WRITE-PACKED-BIT-VECTOR" - "WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME" - "XEP-SETUP-SP" - "LABEL-ID" "FIXUP" "FIXUP-FLAVOR" "FIXUP-NAME" "FIXUP-OFFSET" - "FIXUP-P" "MAKE-FIXUP" - "DEF-ALLOC" - "VAR-ALLOC" - "SAFE-FDEFN-FUN" - "NOTE-FIXUP" - "DEF-CASSER" - "DEF-REFFER" - "EMIT-CONSTANT" - "EMIT-NOP" - "DEF-SETTER" - "FIXED-ALLOC" - "MAKE-FUNCALLABLE-INSTANCE-TRAMP" - "RETURN-SINGLE" - "NOTE-NEXT-INSTRUCTION" - "SET-SLOT" "INIT-SLOT" - "LOCATION-NUMBER" - "*COMPONENT-BEING-COMPILED*" - "BLOCK-NUMBER" - "IR2-BLOCK-BLOCK" - "VOP-BLOCK" - "VOP-NEXT" "NEXT-VOP-IS" "REPLACE-VOPS" - "VOP-NAME" "VOP-CODEGEN-INFO" - - "IMMEDIATE-CONSTANT-SC" - "BOXED-IMMEDIATE-SC-P" - "COMBINATION-IMPLEMENTATION-STYLE" - "CONVERT-CONDITIONAL-MOVE-P" - "LOCATION-PRINT-NAME" - "MAKE-CALL-OUT-TNS" - "STANDARD-ARG-LOCATION" - "STANDARD-ARG-LOCATION-SC" - "ARG-COUNT-SC" - "CLOSURE-SC" - "MAKE-RETURN-PC-PASSING-LOCATION" - "MAKE-OLD-FP-PASSING-LOCATION" - "MAKE-OLD-FP-SAVE-LOCATION" - "RETURN-PC-PASSING-OFFSET" - "OLD-FP-PASSING-OFFSET" - "MAKE-RETURN-PC-SAVE-LOCATION" - "MAKE-ARG-COUNT-LOCATION" - "MAKE-NFP-TN" - "MAKE-NUMBER-STACK-POINTER-TN" - "MAKE-UNKNOWN-VALUES-LOCATIONS" - "SELECT-COMPONENT-FORMAT" - "MAKE-NLX-SP-TN" - "MAKE-DYNAMIC-STATE-TNS" - "MAKE-NLX-ENTRY-ARG-START-LOCATION" - "GENERATE-CALL-SEQUENCE" - "GENERATE-RETURN-SEQUENCE" - "WITH-COMPILER-ERROR-RESIGNALLING" - "WITH-SOURCE-LOCATION" - "XDEFUN" ; extended defun for defstruct - - "BRANCH-IF" "MULTIWAY-BRANCH-IF-EQ" - - ;; for SB-COVER - "*CODE-COVERAGE-INFO*" "CODE-COVERAGE-RECORD-MARKED" - "CLEAR-CODE-COVERAGE" "RESET-CODE-COVERAGE" - "+CODE-COVERAGE-UNMARKED+" - ;; for SB-INTROSPECT - "MAP-PACKED-XREF-DATA" "MAP-SIMPLE-FUNS" - - "DO-BLOCKS" "DO-BLOCKS-BACKWARDS" - "DO-NODES" "DO-NODES-BACKWARDS")) - - #s(sb-cold:package-data - :name "SB-DEBUG" - :doc - "sorta public: Eventually this should become the debugger interface, with -basic stuff like BACKTRACE and ARG. For now, the actual supported interface -is still mixed indiscriminately with low-level internal implementation stuff -like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." - :use ("CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-KERNEL" "SB-DI") - :reexport ("*DEBUG-PRINT-VARIABLE-ALIST*") - :export ("*BACKTRACE-FRAME-COUNT*" - "*DEBUG-BEGINNER-HELP-P*" - "*DEBUG-CONDITION*" - "*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*" - "*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*" - "*METHOD-FRAME-STYLE*" - "*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*" - "ARG" - "INTERNAL-DEBUG" "VAR" - "*STACK-TOP-HINT*" - "*TRACE-ENCAPSULATE-DEFAULT*" - "FRAME-HAS-DEBUG-TAG-P" - "UNWIND-TO-FRAME-AND-CALL" - ;; Deprecated - "BACKTRACE" "BACKTRACE-AS-LIST" - ;; Replaced by - "PRINT-BACKTRACE" "LIST-BACKTRACE")) - - #s(sb-cold:package-data - :name "SB-DI" - :doc "private: primitives used to write debuggers" - :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL" "SB-SYS" "SB-VM") - :import-from (("SB-C" - "DEBUG-SOURCE-NAMESTRING" - "DEBUG-SOURCE-CREATED" - "MAKE-DEBUG-SOURCE" - "DEBUG-SOURCE" "DEBUG-SOURCE-P" - "CORE-DEBUG-SOURCE" "CORE-DEBUG-SOURCE-P" - "CORE-DEBUG-SOURCE-FORM")) - :reexport ("DEBUG-SOURCE-NAMESTRING" - "DEBUG-SOURCE-CREATED" - "DEBUG-SOURCE" "DEBUG-SOURCE-P") - :export ("ACTIVATE-BREAKPOINT" - "AMBIGUOUS-DEBUG-VARS" "AMBIGUOUS-VAR-NAME" "BREAKPOINT" - "BREAKPOINT-ACTIVE-P" "BREAKPOINT-HOOK-FUN" "BREAKPOINT-INFO" - "BREAKPOINT-KIND" "BREAKPOINT-P" "BREAKPOINT-WHAT" "CODE-LOCATION" - "CODE-LOCATION-DEBUG-BLOCK" "CODE-LOCATION-DEBUG-FUN" - "CODE-LOCATION-DEBUG-SOURCE" "CODE-LOCATION-FORM-NUMBER" - "CODE-LOCATION-P" "CODE-LOCATION-TOPLEVEL-FORM-OFFSET" - "CODE-LOCATION-CONTEXT" - "CODE-LOCATION-UNKNOWN-P" "CODE-LOCATION=" "DEACTIVATE-BREAKPOINT" - "DEBUG-BLOCK" "DEBUG-BLOCK-ELSEWHERE-P" "DEBUG-BLOCK-P" - "DEBUG-CONDITION" "DEBUG-ERROR" - "DEBUG-FUN" "DEBUG-FUN-FUN" "DEBUG-FUN-KIND" - "DEBUG-FUN-LAMBDA-LIST" "DEBUG-FUN-NAME" "DEBUG-FUN-CLOSURE-NAME" - "DEBUG-FUN-P" "DEBUG-FUN-START-LOCATION" - "DEBUG-FUN-SYMBOL-VARS" - "DEBUG-VAR" "DEBUG-VAR-ID" "DEBUG-VAR-INFO-AVAILABLE" - "DEBUG-VAR-SYMBOL-NAME" "DEBUG-VAR-P" "DEBUG-VAR-PACKAGE-NAME" - "DEBUG-VAR-SYMBOL" "DEBUG-VAR-VALID-VALUE" - "DEBUG-VAR-VALIDITY" "DEBUG-VAR-VALUE" - "DELETE-BREAKPOINT" - "DO-DEBUG-BLOCK-LOCATIONS" "DO-DEBUG-FUN-BLOCKS" - "DO-DEBUG-FUN-VARS" - "ERROR-CONTEXT" - "FORM-NUMBER-TRANSLATIONS" - "FRAME" "FRAME-CATCHES" "FRAME-CODE-LOCATION" - "FRAME-DEBUG-FUN" "FRAME-DOWN" - "FRAME-FUN-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP" - "GET-TOPLEVEL-FORM" - "REPLACE-FRAME-CATCH-TAG" - "FUN-DEBUG-FUN" "FUN-END-COOKIE-VALID-P" - "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE" - "LAMBDA-LIST-UNAVAILABLE" "MAKE-BREAKPOINT" "NO-DEBUG-BLOCKS" - "NO-DEBUG-FUN-RETURNS" "PREPROCESS-FOR-EVAL" - "EVAL-IN-FRAME" "RETURN-FROM-FRAME" "SOURCE-PATH-CONTEXT" - "TOP-FRAME" "UNHANDLED-DEBUG-CONDITION" - "UNKNOWN-DEBUG-VAR" - "CODE-LOCATION-KIND" "FLUSH-FRAMES-ABOVE")) - - #s(sb-cold:package-data - :name "SB-DISASSEM" - :doc "private: stuff related to the implementation of the disassembler" - :use ("CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-KERNEL" "SB-DI") - :export ("*DISASSEM-NOTE-COLUMN*" "*DISASSEM-OPCODE-COLUMN-WIDTH*" - "*DISASSEM-LOCATION-COLUMN-WIDTH*" - "ALIGN" ;; prevent it from being removed, older Slime versions are using it - "ARG-VALUE" "DISASSEM-STATE" - "DISASSEMBLE-CODE-COMPONENT" - "DISASSEMBLE-FUN" "DISASSEMBLE-MEMORY" - "DISASSEMBLE-INSTRUCTION" - "DISASSEMBLE-SEGMENT" "DISASSEMBLE-SEGMENTS" - "DSTATE-BYTE-ORDER" - "DSTATE-GETPROP" - "DSTATE-SETPROP" - "DSTATE-SEGMENT-SAP" - "DSTATE-OPERANDS" - "FIND-INST" - "GET-CODE-SEGMENTS" "GET-FUN-SEGMENTS" - "GET-INST-SPACE" "HANDLE-BREAK-ARGS" - "LABEL-SEGMENTS" - "MAYBE-NOTE-ASSEMBLER-ROUTINE" - "MAYBE-NOTE-ASSOCIATED-STORAGE-REF" - "MAYBE-NOTE-NIL-INDEXED-OBJECT" - "MAYBE-NOTE-NIL-INDEXED-SYMBOL-SLOT-REF" - "MAYBE-NOTE-SINGLE-STORAGE-REF" - "MAYBE-NOTE-STATIC-SYMBOL" - "NOTE" - "NOTE-CODE-CONSTANT" - "OPERAND" - "PRIN1-QUOTED-SHORT" - "PRIN1-SHORT" "PRINT-BYTES" - "PRINT-CURRENT-ADDRESS" "PRINT-INST" - "PRINT-NOTES-AND-NEWLINE" - "SAP-REF-INT" - "SEG-CODE" "SEG-LENGTH" "SEGMENT" - "SIGN-EXTEND" - "MAKE-DSTATE" - "DEFINE-ARG-TYPE" - "READ-SIGNED-SUFFIX" - "MAKE-MEMORY-SEGMENT" - "MAKE-SEGMENT" "SEG-VIRTUAL-LOCATION" - "DCHUNK" "DCHUNK-ZERO" "*DEFAULT-DSTATE-HOOKS*" - "MAKE-CODE-SEGMENT" "MAKE-OFFS-HOOK" - "DSTATE-SEGMENT" "DSTATE-CUR-OFFS" - "PRINC16" "INSTRUCTION" "DEFINE-INSTRUCTION-FORMAT" - "DSTATE-NEXT-OFFS" - "SEG-SAP-MAKER" "DISASSEMBLE-ASSEM-SEGMENT" - "READ-SUFFIX" - "MAP-SEGMENT-INSTRUCTIONS" - "SET-LOCATION-PRINTING-RANGE" "MAKE-VECTOR-SEGMENT" - "DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR" - "SNARF-ERROR-JUNK")) - - #+sb-dyncount - #s(sb-cold:package-data - :name "SB-DYNCOUNT" - :doc "private: some somewhat-stale code for collecting runtime statistics" - :use ("CL" "SB-ALIEN-INTERNALS" "SB-ALIEN" "SB-BIGNUM" - "SB-EXT" "SB-INT" "SB-KERNEL" "SB-ASSEM" "SB-SYS") - :export ("*COLLECT-DYNAMIC-STATISTICS*" - "COUNT-ME" - "DYNCOUNT-INFO-COUNTS" "DYNCOUNT-INFO-COSTS" - "IR2-COMPONENT-DYNCOUNT-INFO" - "DYNCOUNT-INFO" "DYNCOUNT-INFO-P")) - - #s(sb-cold:package-data - :name "SB-FASL" - :doc "private: stuff related to FASL load/dump logic (and GENESIS)" - :use ("CL" "SB-ALIEN" "SB-ASSEM" "SB-BIGNUM" "SB-C" - "SB-EXT" "SB-INT" "SB-KERNEL" "SB-SYS") - :import-from (("SB-VM" "+FIXUP-KINDS+")) - :export ("*ASSEMBLER-ROUTINES*" - "GET-ASM-ROUTINE" - "+BACKEND-FASL-FILE-IMPLEMENTATION+" - "*FASL-FILE-TYPE*" - "CLOSE-FASL-OUTPUT" - "DUMP-ASSEMBLER-ROUTINES" - "DUMP-FOP" "DUMP-OBJECT" - "DUMPABLE-LAYOUT-P" - "FASL-CONSTANT-ALREADY-DUMPED-P" - "+FASL-FILE-VERSION+" - "FASL-DUMP-COMPONENT" - "FASL-DUMP-COLD-FSET" - "FASL-DUMP-LOAD-TIME-VALUE-LAMBDA" - "FASL-DUMP-TOPLEVEL-LAMBDA-CALL" - "FASL-NOTE-HANDLE-FOR-CONSTANT" - "FASL-OUTPUT" "FASL-OUTPUT-P" - "FASL-OUTPUT-ENTRY-TABLE" "FASL-OUTPUT-STREAM" - "FASL-NOTE-DUMPABLE-INSTANCE" - "LOAD-FORM-IS-DEFAULT-MLFSS-P" - "*!LOAD-TIME-VALUES*" - "OPEN-FASL-OUTPUT" - "*!COLD-DEFSYMBOLS*" "*!COLD-DEFUNS*" - "*!COLD-SETF-MACROS*" "*!COLD-TOPLEVELS*" - "COLD-CONS" "COLD-INTERN" "COLD-PUSH" "COLD-TARGET-PUSH")) - - ;; This package is a grab bag for things which used to be internal - ;; symbols in package COMMON-LISP. Lots of these symbols are accessed - ;; with explicit SB-IMPL:: prefixes in the code. It would be nice to - ;; reduce the use of this practice, so if symbols from here which are - ;; accessed that way are found to belong more appropriately in an - ;; existing package (e.g. SB-KERNEL or SB-SYS or SB-EXT or SB-FASL), - ;; I (WHN 19990223) encourage maintainers to move them there.. - #s(sb-cold:package-data - :name "SB-IMPL" - :doc "private: a grab bag of implementation details" - :import-from (("SB-KERNEL" "*PACKAGE-NAMES*")) - :export ("FORMAT-MICROSECONDS" "FORMAT-MILLISECONDS" ; for ~/fmt/ - "PRINT-TYPE" "PRINT-TYPE-SPECIFIER" - ;; protect from tree shaker so we can test this function - "EXPAND-SYMBOL-CASE" - ;; symbols used by sb-simple-streams - "ANSI-STREAM-CLEAR-INPUT" - "ANSI-STREAM-FRESH-LINE" "ANSI-STREAM-LISTEN" - "ANSI-STREAM-READ-BYTE" "ANSI-STREAM-READ-CHAR" - "ANSI-STREAM-READ-CHAR-NO-HANG" "ANSI-STREAM-READ-LINE" - "ANSI-STREAM-READ-SEQUENCE" "ANSI-STREAM-PEEK-CHAR" - "ANSI-STREAM-UNREAD-CHAR" "ANSI-STREAM-WRITE-SEQUENCE" - "DISPATCH-TABLES" "CHARACTER-MACRO-HASH-TABLE" "CHARACTER-MACRO-ARRAY" - "TOKEN-DELIMITERP" "WHITESPACE[2]P" "WITH-READ-BUFFER" - ;; other - "%MAKUNBOUND") - :use ("CL" "SB-ALIEN" "SB-BIGNUM" "SB-DEBUG" "SB-EXT" - "SB-FASL" "SB-GRAY" "SB-INT" "SB-KERNEL" "SB-SYS")) - - #s(sb-cold:package-data - :name "SB-EXT" - :doc "public: miscellaneous supported extensions to the ANSI Lisp spec" - :use ("CL" "SB-ALIEN" "SB-INT" "SB-SYS" "SB-GRAY") - :export ( ;; Information about how the program was invoked is - ;; nonstandard but very useful. - "*POSIX-ARGV*" "*CORE-PATHNAME*" "*RUNTIME-PATHNAME*" - "POSIX-GETENV" "POSIX-ENVIRON" - - ;; Customizing initfile locations - "*USERINIT-PATHNAME-FUNCTION*" - "*SYSINIT-PATHNAME-FUNCTION*" - - "*DEFAULT-EXTERNAL-FORMAT*" - "*DEFAULT-C-STRING-EXTERNAL-FORMAT*" - - ;; Compare and Swap support - "CAS" - "COMPARE-AND-SWAP" - "DEFCAS" - "DEFINE-CAS-EXPANDER" - "GET-CAS-EXPANSION" - - ;; Other atomic operations and types related to them - "ATOMIC-INCF" - "ATOMIC-DECF" - "ATOMIC-UPDATE" - "ATOMIC-PUSH" - "ATOMIC-POP" - "WORD" - "MOST-POSITIVE-WORD" - - ;; Not an atomic operation, but should be used with them - "SPIN-LOOP-HINT" - - ;; Waiting for arbitrary events. - "WAIT-FOR" - - ;; Time related things - "CALL-WITH-TIMING" - "GET-TIME-OF-DAY" - - ;; People have various good reasons to mess with the GC. - "HEAP-ALLOCATED-P" - "STACK-ALLOCATED-P" - "*AFTER-GC-HOOKS*" - "BYTES-CONSED-BETWEEN-GCS" - "GC" "GET-BYTES-CONSED" - "*GC-RUN-TIME*" - "PURIFY" - "DYNAMIC-SPACE-SIZE" - ;; Gencgc only, but symbols exist for manual building - ;; convenience on all platforms. - "GENERATION-AVERAGE-AGE" - "GENERATION-BYTES-ALLOCATED" - "GENERATION-BYTES-CONSED-BETWEEN-GCS" - "GENERATION-MINIMUM-AGE-BEFORE-GC" - "GENERATION-NUMBER-OF-GCS" - "GENERATION-NUMBER-OF-GCS-BEFORE-PROMOTION" - "GC-LOGFILE" - - ;; Stack allocation control - "*STACK-ALLOCATE-DYNAMIC-EXTENT*" - - ;; Customizing printing of compiler and debugger messages - "*COMPILER-PRINT-VARIABLE-ALIST*" - "*DEBUG-PRINT-VARIABLE-ALIST*" - "COMPILE-FILE-LINE" - "COMPILE-FILE-POSITION" - - ;; Hooks into init & save sequences - "*INIT-HOOKS*" "*SAVE-HOOKS*" "*EXIT-HOOKS*" - "*FORCIBLY-TERMINATE-THREADS-ON-EXIT*" - - ;; Controlling exiting other threads. - "*EXIT-TIMEOUT*" - - ;; There is no one right way to report progress on - ;; hairy compiles. - "*COMPILE-PROGRESS*" - - ;; The default behavior for block compilation. - "*BLOCK-COMPILE-DEFAULT*" - - ;; It can be handy to be able to evaluate expressions involving - ;; the thing under examination by CL:INSPECT. - "*INSPECTED*" - - ;; There is no one right way to do efficiency notes. - "*EFFICIENCY-NOTE-COST-THRESHOLD*" "*EFFICIENCY-NOTE-LIMIT*" - - ;; There's no one right way to report errors. - "*ENCLOSING-SOURCE-CUTOFF*" - "*UNDEFINED-WARNING-LIMIT*" - - ;; and for dedicated users who really want to customize - ;; error reporting, we have - "DEFINE-SOURCE-CONTEXT" - "WITH-CURRENT-SOURCE-FORM" - - ;; and given how many users dislike strict treatment of - ;; DEFCONSTANT, let's give them enough rope to escape by - "DEFCONSTANT-UNEQL" "DEFCONSTANT-UNEQL-NAME" - "DEFCONSTANT-UNEQL-NEW-VALUE" "DEFCONSTANT-UNEQL-OLD-VALUE" - - ;; global lexicals, access to global symbol values - "DEFGLOBAL" - "DEFINE-LOAD-TIME-GLOBAL" - "SYMBOL-GLOBAL-VALUE" - - "FILE-EXISTS" - "FILE-DOES-NOT-EXIST" - "DELETE-FILE-ERROR" - "SUPERSEDE" - "OVERWRITE" - "RENAME" - "CREATE" - "RETRY" - - ;; package extensions - ;; - ;; locks - "PACKAGE-LOCKED-P" - "LOCK-PACKAGE" - "UNLOCK-PACKAGE" - "PACKAGE-IMPLEMENTED-BY-LIST" - "PACKAGE-IMPLEMENTS-LIST" - "ADD-IMPLEMENTATION-PACKAGE" - "REMOVE-IMPLEMENTATION-PACKAGE" - "WITH-UNLOCKED-PACKAGES" - "PACKAGE-LOCK-VIOLATION" - "PACKAGE-LOCKED-ERROR" - "SYMBOL-PACKAGE-LOCKED-ERROR" - "PACKAGE-LOCKED-ERROR-SYMBOL" - "WITHOUT-PACKAGE-LOCKS" - "DISABLE-PACKAGE-LOCKS" - "ENABLE-PACKAGE-LOCKS" - ;; local nicknames - "ADD-PACKAGE-LOCAL-NICKNAME" - "REMOVE-PACKAGE-LOCAL-NICKNAME" - "PACKAGE-LOCAL-NICKNAMES" - "PACKAGE-LOCALLY-NICKNAMED-BY-LIST" - - "PACKAGE-DOES-NOT-EXIST" "READER-PACKAGE-DOES-NOT-EXIST" - ;; behaviour on DEFPACKAGE variance - "*ON-PACKAGE-VARIANCE*" - - ;; Custom conditions & condition accessors for users to handle. - "CODE-DELETION-NOTE" - "COMPILER-NOTE" - "IMPLICIT-GENERIC-FUNCTION-NAME" - "IMPLICIT-GENERIC-FUNCTION-WARNING" - "INVALID-FASL" - - "NAME-CONFLICT" "NAME-CONFLICT-FUNCTION" - "NAME-CONFLICT-DATUM" "NAME-CONFLICT-SYMBOLS" - "RESOLVE-CONFLICT" - - ;; Deprecation stuff - "DEPRECATED" ; declaration - "DEPRECATION-CONDITION" - "DEPRECATION-CONDITION-NAMESPACE" - "DEPRECATION-CONDITION-NAME" - "DEPRECATION-CONDITION-SOFTWARE" - "DEPRECATION-CONDITION-VERSION" - "DEPRECATION-CONDITION-REPLACEMENTS" - "DEPRECATION-CONDITION-RUNTIME-ERROR" - "EARLY-DEPRECATION-WARNING" - "LATE-DEPRECATION-WARNING" - "FINAL-DEPRECATION-WARNING" - "DEPRECATION-ERROR" ; condition and function - - "PRINT-UNREADABLY" - - ;; Readtable normalization control - "READTABLE-BASE-CHAR-PREFERENCE" - "READTABLE-NORMALIZATION" - - ;; and a mechanism for controlling same at compile time - "MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS" - - ;; and one for controlling same at runtime - "*MUFFLED-WARNINGS*" - - ;; specification which print errors to ignore ala *break-on-signal* - "*SUPPRESS-PRINT-ERRORS*" - - ;; extended declarations.. - "ALWAYS-BOUND" "FREEZE-TYPE" "GLOBAL" "INHIBIT-WARNINGS" - "MAYBE-INLINE" "START-BLOCK" "END-BLOCK" - - ;; ..and variables to control compiler policy - "*INLINE-EXPANSION-LIMIT*" - "*DERIVE-FUNCTION-TYPES*" - - ;; ..and inspector of compiler policy - "DESCRIBE-COMPILER-POLICY" - "RESTRICT-COMPILER-POLICY" - "SET-MACRO-POLICY" - "FOLD-IDENTICAL-CODE" ; this is a verb, not a compiler policy - - ;; a special form for breaking out of our "declarations - ;; are assertions" default - "TRULY-THE" - - ;; Misc. array and vector tools. - "ARRAY-STORAGE-VECTOR" - "PRIMITIVE-OBJECT-SIZE" - - ;; This is something which must exist inside any Common - ;; Lisp implementation, and which someone writing a - ;; customized toplevel might well want. It seems perverse - ;; to hide it from them.. - "INTERACTIVE-EVAL" - - ;; Used by LOAD and EVAL-WHEN to pass toplevel indexes - ;; to compiler. - "EVAL-TLF" - - ;; weak pointers and finalization - "CANCEL-FINALIZATION" - "FINALIZE" - "MAKE-WEAK-POINTER" - "WEAK-POINTER" - "WEAK-POINTER-P" - "WEAK-POINTER-VALUE" - "MAKE-WEAK-VECTOR" - "WEAK-VECTOR-P" - - ;; Hash table extensions - "DEFINE-HASH-TABLE-TEST" - "HASH-TABLE-SYNCHRONIZED-P" - "HASH-TABLE-WEAKNESS" - "WITH-LOCKED-HASH-TABLE" - - ;; If the user knows we're doing IEEE, he might reasonably - ;; want to do this stuff. - "FLOAT-DENORMALIZED-P" - "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P" - "FLOAT-INFINITY-P" - "SHORT-FLOAT-NEGATIVE-INFINITY" - "SHORT-FLOAT-POSITIVE-INFINITY" - "SINGLE-FLOAT-NEGATIVE-INFINITY" - "SINGLE-FLOAT-POSITIVE-INFINITY" - "DOUBLE-FLOAT-NEGATIVE-INFINITY" - "DOUBLE-FLOAT-POSITIVE-INFINITY" - "LONG-FLOAT-NEGATIVE-INFINITY" - "LONG-FLOAT-POSITIVE-INFINITY" - - ;; saving Lisp images - "SAVE-LISP-AND-DIE" - - ;; provided for completeness to make it more convenient - ;; to use command-line --disable-debugger functionality - ;; in oddball situations (like building core files using - ;; scripts which run unattended, when the core files are - ;; intended for interactive use) - "DISABLE-DEBUGGER" - "ENABLE-DEBUGGER" - - ;; the mechanism by which {en,dis}able-debugger works is - ;; also exported for people writing alternative toplevels - ;; (Emacs, CLIM interfaces, etc) - "*INVOKE-DEBUGGER-HOOK*" - - ;; miscellaneous useful supported extensions - "QUIT" "EXIT" - "*ED-FUNCTIONS*" - "*MODULE-PROVIDER-FUNCTIONS*" - "MAP-DIRECTORY" - "WITH-TIMEOUT" "TIMEOUT" - "SEED-RANDOM-STATE" - "TYPEXPAND-1" "TYPEXPAND" "TYPEXPAND-ALL" - "DEFINED-TYPE-NAME-P" "VALID-TYPE-SPECIFIER-P" - "DELETE-DIRECTORY" - "SET-SBCL-SOURCE-LOCATION" - "*DISASSEMBLE-ANNOTATE*" - "PRINT-SYMBOL-WITH-PREFIX" - "*PRINT-VECTOR-LENGTH*" - "DECIMAL-WITH-GROUPED-DIGITS-WIDTH" - ;;"OBJECT-SIZE" - - ;; stepping interface - "STEP-CONDITION" "STEP-FORM-CONDITION" "STEP-FINISHED-CONDITION" - "STEP-VALUES-CONDITION" - "STEP-CONDITION-FORM" "STEP-CONDITION-RESULT" - "STEP-CONTINUE" "STEP-NEXT" "STEP-INTO" - "STEP-CONDITION-ARGS" "*STEPPER-HOOK*" "STEP-OUT" - - ;; RUN-PROGRAM is not only useful for users, but also - ;; useful to implement parts of SBCL itself, so we're - ;; going to have to implement it anyway, so we might - ;; as well support it. And then once we're committed - ;; to implementing RUN-PROGRAM, it's nice to have it - ;; return a PROCESS object with operations defined on - ;; that object. - "RUN-PROGRAM" - "PROCESS-ALIVE-P" "PROCESS-CLOSE" - "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE" - "PROCESS-INPUT" "PROCESS-KILL" "PROCESS-OUTPUT" "PROCESS-P" - "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS" - "PROCESS-STATUS-HOOK" "PROCESS-WAIT" - - ;; pathnames - "NATIVE-PATHNAME" - "PARSE-NATIVE-NAMESTRING" - "NATIVE-NAMESTRING" - - ;; external-format support - "OCTETS-TO-STRING" "STRING-TO-OCTETS" - - ;; Whether to use the interpreter or the compiler for EVAL - "*EVALUATOR-MODE*" - - ;; timer - "TIMER" "MAKE-TIMER" "TIMER-NAME" "TIMER-SCHEDULED-P" - "SCHEDULE-TIMER" "UNSCHEDULE-TIMER" "LIST-ALL-TIMERS" - - ;; SIMD pack - #+sb-simd-pack - ("SIMD-PACK" - "SIMD-PACK-P" - "%MAKE-SIMD-PACK-UB32" - "%MAKE-SIMD-PACK-UB64" - "%MAKE-SIMD-PACK-DOUBLE" - "%MAKE-SIMD-PACK-SINGLE" - "%SIMD-PACK-UB32S" - "%SIMD-PACK-UB64S" - "%SIMD-PACK-DOUBLES" - "%SIMD-PACK-SINGLES") - #+sb-simd-pack-256 - ("SIMD-PACK-256" - "SIMD-PACK-256-P" - "%MAKE-SIMD-PACK-256-UB32" - "%MAKE-SIMD-PACK-256-UB64" - "%MAKE-SIMD-PACK-256-DOUBLE" - "%MAKE-SIMD-PACK-256-SINGLE" - "%SIMD-PACK-256-UB32S" - "%SIMD-PACK-256-UB64S" - "%SIMD-PACK-256-DOUBLES" - "%SIMD-PACK-256-SINGLES") - - ;; versioning utility - "ASSERT-VERSION->=" - "UNKNOWN-KEYWORD-ARGUMENT" - "UNKNOWN-KEYWORD-ARGUMENT-NAME")) - - #s(sb-cold:package-data - :name "SB-FORMAT" - :doc "private: implementation of FORMAT and friends" - :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") - :export ("%COMPILER-WALK-FORMAT-STRING" "FORMAT-ERROR" "TOKENS")) - - #s(sb-cold:package-data - :name "SB-GRAY" - :doc - "public: an implementation of the stream-definition-by-user -Lisp extension proposal by David N. Gray" - :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") - :export ("FUNDAMENTAL-BINARY-STREAM" - "FUNDAMENTAL-BINARY-INPUT-STREAM" - "FUNDAMENTAL-BINARY-OUTPUT-STREAM" "FUNDAMENTAL-CHARACTER-STREAM" - "FUNDAMENTAL-CHARACTER-INPUT-STREAM" - "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" - "FUNDAMENTAL-INPUT-STREAM" "FUNDAMENTAL-OUTPUT-STREAM" - "FUNDAMENTAL-STREAM" - "STREAM-ADVANCE-TO-COLUMN" "STREAM-CLEAR-INPUT" - "STREAM-CLEAR-OUTPUT" "STREAM-FILE-POSITION" "STREAM-FINISH-OUTPUT" "STREAM-FORCE-OUTPUT" - "STREAM-FRESH-LINE" "STREAM-LINE-COLUMN" "STREAM-LINE-LENGTH" - "STREAM-LISTEN" "STREAM-PEEK-CHAR" "STREAM-READ-BYTE" - "STREAM-READ-CHAR" "STREAM-READ-CHAR-NO-HANG" "STREAM-READ-LINE" - "STREAM-READ-SEQUENCE" "STREAM-START-LINE-P" "STREAM-TERPRI" - "STREAM-UNREAD-CHAR" - "STREAM-WRITE-BYTE" "STREAM-WRITE-CHAR" "STREAM-WRITE-SEQUENCE" - "STREAM-WRITE-STRING")) - - #s(sb-cold:package-data - :name "SB-INT" - :doc - "private: miscellaneous unsupported extensions to the ANSI spec. Much of -the stuff in here originated in CMU CL's EXTENSIONS package and is retained, -possibly temporarily, because it might be used internally." - :use ("CL" "SB-ALIEN" "SB-GRAY" "SB-FASL" "SB-SYS") - :export (;; lambda list keyword extensions - "&MORE" - - ;; utilities for floating point zero handling - "FP-ZERO-P" - "NEG-FP-ZERO" - - ;; Advice to the compiler that it doesn't need to assert types. - "EXPLICIT-CHECK" - ;; Stack allocation without any questions asked - "TRULY-DYNAMIC-EXTENT" - - "WITH-SYSTEM-MUTEX" - "HASH-TABLE-LOCK" - - ;; generic set implementation backed by a list that upgrades - ;; to a hashtable if a certain size is exceeded. - "ADD-TO-XSET" - "ALLOC-XSET" - "MAP-XSET" - "XSET" - "XSET-COUNT" - "XSET-EMPTY-P" - "XSET-INTERSECTION" - "XSET-MEMBER-P" - "XSET-MEMBERS" - "XSET-SUBSET-P" - "XSET-UNION" - - ;; sparse set implementation backed by a lightweight hashtable - "COPY-SSET" - "DO-SSET-ELEMENTS" - "MAKE-SSET" - "SSET" "SSET-ELEMENT" - "SSET-ADJOIN" "SSET-DELETE" "SSET-EMPTY" "SSET-COUNT" - "SSET-MEMBER" - - ;; communication between the runtime and Lisp - "*CORE-STRING*" - - ;; INFO stuff doesn't belong in a user-visible package, we - ;; should be able to change it without apology. - "*INFO-ENVIRONMENT*" - "*RECOGNIZED-DECLARATIONS*" - "+INFOS-PER-WORD+" - "+FDEFN-INFO-NUM+" - "+NIL-PACKED-INFOS+" - "ATOMIC-SET-INFO-VALUE" - "CALL-WITH-EACH-GLOBALDB-NAME" - "CLEAR-INFO" - "CLEAR-INFO-VALUES" - "DEFINE-INFO-TYPE" - "FIND-FDEFN" - "SYMBOL-FDEFN" - "GET-INFO-VALUE-INITIALIZING" - "GLOBALDB-SXHASHOID" - "GLOBAL-FTYPE" - "INFO" - "INFO-FIND-AUX-KEY/PACKED" - "INFO-GETHASH" - "INFO-MAPHASH" - "INFO-NUMBER" - "INFO-NUMBER-BITS" - "INFO-VECTOR-FDEFN" - "MAKE-INFO-HASHTABLE" - "META-INFO" - "META-INFO-NUMBER" - "PACKED-INFO-FIELD" - "PACKED-INFO-INSERT" - "PCL-METHODFN-NAME-P" - "SET-INFO-VALUE" - "SHOW-INFO" - "UPDATE-SYMBOL-INFO" - "WITH-GLOBALDB-NAME" - "%BOUNDP" - - ;; Calling a list of hook functions, plus error handling. - "CALL-HOOKS" - ;; Constant form evaluation - "CONSTANT-FORM-VALUE" - "CONSTANT-TYPEP" - - ;; stepping control - "*STEPPING*" - - ;; packages grabbed once and for all - "*KEYWORD-PACKAGE*" "*CL-PACKAGE*" - - ;; hash mixing operations - "MIX" "MIXF" "WORD-MIX" - - ;; Macroexpansion that doesn't touch special forms - "%MACROEXPAND" - "%MACROEXPAND-1" - - "*SETF-FDEFINITION-HOOK*" - - ;; error-reporting facilities - "ARGUMENTS-OUT-OF-DOMAIN-ERROR" - "CLOSED-STREAM-ERROR" "CLOSED-SAVED-STREAM-ERROR" - "COMPILED-PROGRAM-ERROR" - "COMPILER-MACRO-KEYWORD-PROBLEM" - "ENCAPSULATED-CONDITION" - "INVALID-ARRAY-ERROR" - "INVALID-ARRAY-INDEX-ERROR" - "INVALID-ARRAY-P" - "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" - "SIMPLE-PARSE-ERROR" - "SIMPLE-PROGRAM-ERROR" "%PROGRAM-ERROR" - "SIMPLE-READER-ERROR" - "SIMPLE-READER-PACKAGE-ERROR" - "SIMPLE-REFERENCE-ERROR" - "SIMPLE-REFERENCE-WARNING" - "SIMPLE-STREAM-ERROR" - "SIMPLE-STORAGE-CONDITION" - "SIMPLE-STYLE-WARNING" - "STREAM-ERROR-POSITION-INFO" - "TRY-RESTART" - - "BROKEN-PIPE" - - ;; error-signalling facilities - "STANDARD-READTABLE-MODIFIED-ERROR" - "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" - "ARRAY-BOUNDING-INDICES-BAD-ERROR" - "CIRCULAR-LIST-ERROR" - "SEQUENCE-BOUNDING-INDICES-BAD-ERROR" - "SPECIAL-FORM-FUNCTION" - "STYLE-WARN" "SIMPLE-COMPILER-NOTE" - "TWO-ARG-CHAR-EQUAL" "TWO-ARG-CHAR-NOT-EQUAL" - "TWO-ARG-CHAR-LESSP" "TWO-ARG-CHAR-NOT-LESSP" - "TWO-ARG-CHAR-GREATERP" "TWO-ARG-CHAR-NOT-GREATERP" - "CHAR-EQUAL-CONSTANT" "CHAR-CASE-INFO" - ;; FIXME: potential SB-EXT exports - "CHARACTER-CODING-ERROR" - "CHARACTER-DECODING-ERROR" "CHARACTER-DECODING-ERROR-OCTETS" - "CHARACTER-ENCODING-ERROR" "CHARACTER-ENCODING-ERROR-CODE" - "STREAM-DECODING-ERROR" "STREAM-ENCODING-ERROR" - "C-STRING-ENCODING-ERROR" - "C-STRING-DECODING-ERROR" - "ATTEMPT-RESYNC" "FORCE-END-OF-FILE" - - ;; bootstrapping magic, to make things happen both in - ;; the cross-compilation host compiler's environment and - ;; in the cross-compiler's environment - "DEF!STRUCT" "DEF!TYPE" - ;; bootstrapping magic of a different kind, wherein things happen - ;; as they ordinarily do, plus during second genesis. - "!DEFINE-LOAD-TIME-GLOBAL" - "*!REMOVABLE-SYMBOLS*" - - ;; bootstrapping macro whose effect is to delay until warm load. - "DEF*METHOD" - "!SET-LOAD-FORM-METHOD" - - ;; stuff for hinting to the compiler - "NAMED-DS-BIND" - "NAMED-LAMBDA" - - ;; other variations on DEFFOO stuff useful for bootstrapping - ;; and cross-compiling - "DEFCONSTANT-EQX" - "DEFINE-UNSUPPORTED-FUN" - - ;; messing with PATHNAMEs - "MAKE-TRIVIAL-DEFAULT-PATHNAME" - "PHYSICALIZE-PATHNAME" - "SANE-DEFAULT-PATHNAME-DEFAULTS" - "SBCL-HOMEDIR-PATHNAME" - "SIMPLIFY-NAMESTRING" - "DEBUG-SOURCE-NAMESTRING" - "DEBUG-SOURCE-CREATED" - - "*N-BYTES-FREED-OR-PURIFIED*" - - ;; Deprecating stuff - "DEFINE-DEPRECATED-FUNCTION" - "DEFINE-DEPRECATED-VARIABLE" - "DEPRECATION-STATE" - "DEPRECATION-INFO" "MAKE-DEPRECATION-INFO" - "DEPRECATION-INFO-STATE" - "DEPRECATION-INFO-SOFTWARE" - "DEPRECATION-INFO-VERSION" - "DEPRECATION-INFO-REPLACEMENTS" - "PRINT-DEPRECATION-MESSAGE" - "CHECK-DEPRECATED-THING" "CHECK-DEPRECATED-TYPE" - "DEPRECATED-THING-P" - "DEPRECATION-WARN" - "LOADER-DEPRECATION-WARN" - - ;; miscellaneous non-standard but handy user-level functions.. - "ASSQ" "DELQ" "DELQ1" "MEMQ" "POSQ" "NEQ" - "ADJUST-LIST" - "ALIGN-UP" - "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE" - "SANE-PACKAGE" - "COALESCE-TREE-P" - "COMPOUND-OBJECT-P" - "SWAPPED-ARGS-FUN" - "AND/TYPE" "NOT/TYPE" - "ANY/TYPE" "EVERY/TYPE" - "EQUAL-BUT-NO-CAR-RECURSION" - "TYPE-BOUND-NUMBER" "COERCE-NUMERIC-BOUND" - "CONSTANTLY-T" "CONSTANTLY-NIL" "CONSTANTLY-0" - "PSXHASH" - "%BREAK" - "BIT-VECTOR-=" - "PATHNAME=" - "%HASH-TABLE-ALIST" - "HASH-TABLE-EQUALP" - "READ-EVALUATED-FORM" "READ-EVALUATED-FORM-OF-TYPE" - "PICK-BEST-SXHASH-BITS" - - "MAKE-UNPRINTABLE-OBJECT" - "POSSIBLY-BASE-STRINGIZE" - "POWER-OF-TWO-CEILING" - "PRINT-NOT-READABLE-ERROR" - "HASH-TABLE-REPLACE" - "RECONS" - "SET-CLOSURE-NAME" - - ;; ..and macros.. - "COLLECT" - "COPY-LIST-MACRO" - "DO-ANONYMOUS" "DOVECTOR" "DOHASH" "DOPLIST" - "ENSURE-GETHASH" - "GET-SIMILAR" - "NAMED-LET" - "ONCE-ONLY" - "DEFENUM" - "DEFPRINTER" - "*PRINT-IR-NODES-PRETTY*" - "AVER" - "DX-FLET" "DX-LET" - "AWHEN" "ACOND" "IT" - "BINDING*" "EXTRACT-VAR-DECLS" - "!DEF-BOOLEAN-ATTRIBUTE" - "FUNARG-BIND/CALL-FORMS" - "QUASIQUOTE" - "COMMA-P" - "COMMA-EXPR" - "COMMA-KIND" - "UNQUOTE" - "PACKAGE-HASHTABLE" - "PACKAGE-ITER-STEP" - "WITH-REBOUND-IO-SYNTAX" - "WITH-SANE-IO-SYNTAX" - "WITH-PROGRESSIVE-TIMEOUT" - - ;; ..and CONDITIONs.. - "BUG" - "UNSUPPORTED-OPERATOR" - - "BOOTSTRAP-PACKAGE-NAME" - "BOOTSTRAP-PACKAGE-NOT-FOUND" - "DEBOOTSTRAP-PACKAGE" - "SYSTEM-PACKAGE-P" - - "REFERENCE-CONDITION" "REFERENCE-CONDITION-REFERENCES" - "*PRINT-CONDITION-REFERENCES*" - - "DUPLICATE-DEFINITION" "DUPLICATE-DEFINITION-NAME" - "SAME-FILE-REDEFINITION-WARNING" - "PACKAGE-AT-VARIANCE" - "PACKAGE-AT-VARIANCE-ERROR" - "ARRAY-INITIAL-ELEMENT-MISMATCH" - "INITIAL-ELEMENT-MISMATCH-STYLE-WARNING" - "TYPE-WARNING" "TYPE-STYLE-WARNING" - "SLOT-INITFORM-TYPE-STYLE-WARNING" - "LOCAL-ARGUMENT-MISMATCH" - "FORMAT-ARGS-MISMATCH" "FORMAT-TOO-FEW-ARGS-WARNING" - "FORMAT-TOO-MANY-ARGS-WARNING" "EXTENSION-FAILURE" - "STRUCTURE-INITARG-NOT-KEYWORD" "CONSTANT-MODIFIED" - - ;; ..and DEFTYPEs.. - "HASH-CODE" - "INDEX" "LOAD/STORE-INDEX" - "SIGNED-BYTE-WITH-A-BITE-OUT" - "UNSIGNED-BYTE-WITH-A-BITE-OUT" - "SFUNCTION" "UNSIGNED-BYTE*" - "CONSTANT-DISPLACEMENT" - "EXTENDED-FUNCTION-DESIGNATOR" - "EXTENDED-FUNCTION-DESIGNATOR-P" - ;; ..and type predicates - "DOUBLE-FLOAT-P" - "LOGICAL-PATHNAME-P" - "LONG-FLOAT-P" - "SHORT-FLOAT-P" - "SINGLE-FLOAT-P" - "FIXNUMP" - "FIXNUMP-INSTANCE-REF" "FIXNUMP-CAR" "FIXNUMP-CDR" - "BIGNUMP" - "RATIOP" - "UNBOUND-MARKER-P" - - ;; encapsulation - "ENCAPSULATE" "ENCAPSULATED-P" - "UNENCAPSULATE" - "ENCAPSULATE-FUNOBJ" - - ;; various CHAR-CODEs - "BACKSPACE-CHAR-CODE" "BELL-CHAR-CODE" "ESCAPE-CHAR-CODE" - "FORM-FEED-CHAR-CODE" "LINE-FEED-CHAR-CODE" - "RETURN-CHAR-CODE" "RUBOUT-CHAR-CODE" "TAB-CHAR-CODE" - - ;; symbol-hacking idioms - "GENSYMIFY" "GENSYMIFY*" "KEYWORDICATE" "SYMBOLICATE" - "INTERNED-SYMBOL-P" "PACKAGE-SYMBOLICATE" - "LOGICALLY-READONLYIZE" - - ;; certainly doesn't belong in public extensions - ;; FIXME: maybe belongs in %KERNEL with other typesystem stuff? - "CONSTANT-ARG" - - ;; various internal defaults - "*LOAD-SOURCE-DEFAULT-TYPE*" "BASE-CHAR-CODE-LIMIT" - - ;; hash caches - "DEFUN-CACHED" - "DROP-ALL-HASH-CACHES" - - ;; time - "FORMAT-DECODED-TIME" - "FORMAT-UNIVERSAL-TIME" - - ;; used for FORMAT tilde paren - "MAKE-CASE-FROB-STREAM" - - ;; helpers for C library calls - "STRERROR" "SIMPLE-PERROR" - - ;; debuggers' little helpers - #+sb-show("*/SHOW*" - "HEXSTR") - "/SHOW" "/NOSHOW" - "/SHOW0" "/NOSHOW0" - - ;; cross-compilation bootstrap hacks which turn into - ;; placeholders in a target system - "UNCROSS" - "!UNCROSS-FORMAT-CONTROL" - - ;; might as well be shared among the various files which - ;; need it: - "*EOF-OBJECT*" - - ;; allocation to static space - "MAKE-STATIC-VECTOR" - - ;; alien interface utilities - "C-STRINGS->STRING-LIST" - - ;; misc. utilities used internally - "ADDRESS-BASED-COUNTER-VAL" - "DEFINE-FUNCTION-NAME-SYNTAX" "VALID-FUNCTION-NAME-P" ; should be SB-EXT? - "LEGAL-VARIABLE-NAME-P" - "LEGAL-FUN-NAME-P" "LEGAL-FUN-NAME-OR-TYPE-ERROR" - "FUN-NAME-BLOCK-NAME" - "FUN-NAME-INLINE-EXPANSION" - "LISTEN-SKIP-WHITESPACE" - "PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT" - "PARSE-BODY" "PARSE-LAMBDA-LIST" "MAKE-LAMBDA-LIST" - "CHECK-DESIGNATOR" - "CHECK-LAMBDA-LIST-NAMES" - "LAMBDA-LIST-KEYWORD-MASK" - "PARSE-KEY-ARG-SPEC" "PARSE-OPTIONAL-ARG-SPEC" - "LL-KWDS-RESTP" "LL-KWDS-KEYP" "LL-KWDS-ALLOWP" - "MAKE-MACRO-LAMBDA" - "PROPER-LIST-OF-LENGTH-P" "PROPER-LIST-P" - "LIST-OF-LENGTH-AT-LEAST-P" "SEQUENCE-OF-LENGTH-AT-LEAST-P" - "LIST-WITH-LENGTH-P" - "SINGLETON-P" "ENSURE-LIST" - "MISSING-ARG" - "FEATUREP" - "FLUSH-STANDARD-OUTPUT-STREAMS" - "WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST" - "ABOUT-TO-MODIFY-SYMBOL-VALUE" - "SELF-EVALUATING-P" - "PRINT-PRETTY-ON-STREAM-P" - "ARRAY-READABLY-PRINTABLE-P" - "LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P" - "POSITIVE-PRIMEP" - "EVAL-IN-LEXENV" - "SIMPLE-EVAL-IN-LEXENV" - "FORCE" "DELAY" "PROMISE-READY-P" - "FIND-RESTART-OR-CONTROL-ERROR" - "LOAD-AS-SOURCE" - "DESCRIPTOR-SAP" - "DO-PACKED-VARINTS" - - "CLOSURE-EXTRA-VALUES" - "PACK-CLOSURE-EXTRA-VALUES" - "SET-CLOSURE-EXTRA-VALUES" - "+CLOSURE-NAME-INDEX+" - - ;; These could be moved back into SB-EXT if someone has - ;; compelling reasons, but hopefully we can get by - ;; without supporting them, at least not as publicly - ;; accessible things with fixed interfaces. - "GET-FLOATING-POINT-MODES" - "SET-FLOATING-POINT-MODES" - "WITH-FLOAT-TRAPS-MASKED" - - ;; a sort of quasi-unbound tag for use in hash tables - "+EMPTY-HT-SLOT+" - - ;; low-level i/o stuff - "DONE-WITH-FAST-READ-CHAR" - "FAST-READ-BYTE" - "FAST-READ-BYTE-REFILL" - "FAST-READ-CHAR" - "FAST-READ-CHAR-REFILL" - "FAST-READ-S-INTEGER" - "FAST-READ-U-INTEGER" - "FAST-READ-VAR-U-INTEGER" - "FILE-NAME" - "FORM-TRACKING-STREAM" - "FORM-TRACKING-STREAM-OBSERVER" - "FORM-TRACKING-STREAM-P" - "FORM-TRACKING-STREAM-FORM-START-BYTE-POS" - "FORM-TRACKING-STREAM-FORM-START-CHAR-POS" - "LINE/COL-FROM-CHARPOS" - "%INTERN" - "WITH-FAST-READ-BYTE" - "PREPARE-FOR-FAST-READ-CHAR" - "OUT-STREAM-FROM-DESIGNATOR" - "STRINGIFY-OBJECT" - "%WRITE" - - ;; hackery to help set up for cold init - "!BEGIN-COLLECTING-COLD-INIT-FORMS" - "!COLD-INIT-FORMS" - "!COLD-FSET" - "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS" - - ;; catch tags - "TOPLEVEL-CATCHER" - - ;; hooks for contrib/ stuff we're insufficiently sure - ;; about to add to SB-EXT - "*REPL-PROMPT-FUN*" - "*REPL-READ-FORM-FUN*" - - ;; Character database - "**CHARACTER-MISC-DATABASE**" - "**CHARACTER-HIGH-PAGES**" - "**CHARACTER-LOW-PAGES**" - "**CHARACTER-DECOMPOSITIONS**" - "**CHARACTER-PRIMARY-COMPOSITIONS**" - "**CHARACTER-CASES**" - "**CHARACTER-CASE-PAGES**" - "**CHARACTER-COLLATIONS**" - "**UNICODE-CHAR-NAME-DATABASE**" - "**UNICODE-NAME-CHAR-DATABASE**" - "**UNICODE-1-CHAR-NAME-DATABASE**" - "**UNICODE-1-NAME-CHAR-DATABASE**" - "**UNICODE-CHARACTER-NAME-HUFFMAN-TREE**" - - ;; Character database access - "MISC-INDEX" - "CLEAR-FLAG" - "PACK-3-CODEPOINTS" - - ;; Huffman trees - "HUFFMAN-ENCODE" - "HUFFMAN-DECODE" - "BINARY-SEARCH" - "DOUBLE-VECTOR-BINARY-SEARCH")) - - ;; FIXME: This package is awfully huge. It'd probably be good to - ;; split it. There's at least one natural way to split it: the - ;; implementation of the Lisp type system (e.g. TYPE-INTERSECTION and - ;; SPECIFIER-TYPE) could move to a separate package SB-TYPE. (There's - ;; lots of stuff which currently uses the SB-KERNEL package which - ;; doesn't actually use the type system stuff.) And maybe other - ;; possible splits too: - ;; * Pull GC stuff (*GC-INHIBIT*, *GC-PENDING*, etc.) - ;; out into SB-GC. - ;; * Pull special case implementations of sequence functions (e.g. - ;; %MAP-TO-LIST-ARITY-1 and %FIND-POSITION-IF-NOT) and - ;; other sequence function implementation grot into SB-SEQ. - ;; * Pull all the math stuff (%ACOS, %COSH, WORD-LOGICAL-AND...) - ;; into SB-MATH. - ;; * Pull all the array stuff (%ARRAY-DATA, - ;; WITH-ARRAY-DATA, ALLOCATE-VECTOR, HAIRY-DATA-VECTOR-REF...) - ;; into SB-ARRAY. - ;; * Pull all the streams stuff out into SB-STREAM. - ;; * Pull all the OBJECT-NOT-FOO symbols out. Maybe we could even - ;; figure out a way to stop exporting them? Failing that, - ;; they could be in SB-INTERR. - ;; Or better still, since error names are basically meaningless except - ;; for the ~18 errors that are _not_ object-not-, stop naming them. - ;; C just needs a map from number -> string-to-show. - #s(sb-cold:package-data - :name "SB-KERNEL" - :doc - "private: Theoretically this 'hides state and types used for package -integration' (said CMU CL architecture.tex) and that probably was and -is a good idea, but see SB-SYS re. blurring of boundaries." - :use ("CL" "SB-ALIEN" "SB-ALIEN-INTERNALS" "SB-BIGNUM" - "SB-EXT" "SB-FASL" "SB-INT" "SB-SYS" "SB-GRAY") - :reexport (#+sb-simd-pack("SIMD-PACK" - "SIMD-PACK-P" - "%MAKE-SIMD-PACK-UB32" - "%MAKE-SIMD-PACK-UB64" - "%MAKE-SIMD-PACK-DOUBLE" - "%MAKE-SIMD-PACK-SINGLE" - "%SIMD-PACK-UB32S" - "%SIMD-PACK-UB64S" - "%SIMD-PACK-DOUBLES" - "%SIMD-PACK-SINGLES")) - :export ("%%DATA-VECTOR-REFFERS%%" - "%%DATA-VECTOR-SETTERS%%" - "%ACOS" - "%ACOSH" - "%ADJOIN" - "%ADJOIN-EQ" - "%ADJOIN-KEY" - "%ADJOIN-KEY-EQ" - "%ADJOIN-KEY-TEST" - "%ADJOIN-KEY-TEST-NOT" - "%ADJOIN-TEST" - "%ADJOIN-TEST-NOT" - "%ARRAY-AVAILABLE-ELEMENTS" - "%ARRAY-DATA" - "%ARRAY-DATA-VECTOR" ; DO NOT USE !!! - "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" - "%ARRAY-DISPLACED-FROM" - "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" - "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" "%ARRAY-RANK=" - "%ARRAY-ATOMIC-INCF/WORD" - "%ASH/RIGHT" - "%ASSOC" - "%ASSOC-EQ" - "%ASSOC-IF" - "%ASSOC-IF-KEY" - "%ASSOC-IF-NOT" - "%ASSOC-IF-NOT-KEY" - "%ASSOC-KEY" - "%ASSOC-KEY-EQ" - "%ASSOC-KEY-TEST" - "%ASSOC-KEY-TEST-NOT" - "%ASSOC-TEST" - "%ASSOC-TEST-NOT" - "%ASIN" "%ASINH" - "%ATAN" "%ATAN2" "%ATANH" - "%ATOMIC-DEC-CAR" "%ATOMIC-INC-CAR" - "%ATOMIC-DEC-CDR" "%ATOMIC-INC-CDR" - "%ATOMIC-DEC-SYMBOL-GLOBAL-VALUE" - "%ATOMIC-INC-SYMBOL-GLOBAL-VALUE" - "%CALLER-FRAME" - "%CALLER-PC" - "%CHECK-BOUND" "CHECK-BOUND" - "%CHECK-GENERIC-SEQUENCE-BOUNDS" - "%CHECK-VECTOR-SEQUENCE-BOUNDS" - "%CAS-SYMBOL-GLOBAL-VALUE" - "%COPY-INSTANCE" "%COPY-INSTANCE-SLOTS" - "%COMPARE-AND-SWAP-CAR" - "%COMPARE-AND-SWAP-CDR" - "%COMPARE-AND-SWAP-SVREF" - "%COMPARE-AND-SWAP-SYMBOL-INFO" - "%COMPARE-AND-SWAP-SYMBOL-VALUE" - "%CONCATENATE-TO-BASE-STRING" - "%CONCATENATE-TO-STRING" - "%CONCATENATE-TO-SIMPLE-VECTOR" - "%CONCATENATE-TO-LIST" "%CONCATENATE-TO-VECTOR" - "CONTAINS-UNKNOWN-TYPE-P" - "%COS" "%COS-QUICK" - "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD" - "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EQL/INTEGER" - "%EXIT" - "%EXP" "%EXPM1" - "%FIND-POSITION" - "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF" - "%FIND-POSITION-IF-VECTOR-MACRO" "%FIND-POSITION-IF-NOT" - "%FIND-POSITION-IF-NOT-VECTOR-MACRO" - "FIXNUM-MOD-P" - "%HYPOT" - "%INSTANCE-CAS" - "%LDB" "%LOG" "%LOGB" "%LOG10" - "%LAST0" - "%LAST1" - "%LASTN/FIXNUM" - "%LASTN/BIGNUM" - "%LOG1P" - #+long-float "%LONG-FLOAT" - "%MAKE-ARRAY" - "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" - "%MAKE-FUNCALLABLE-STRUCTURE-INSTANCE-ALLOCATOR" - "%MAKE-INSTANCE" - "%MAKE-LISP-OBJ" - "%MAKE-LIST" - "%MAKE-RATIO" - #+sb-simd-pack "%MAKE-SIMD-PACK" - #+sb-simd-pack-256 "%MAKE-SIMD-PACK-256" - "%MAKE-STRUCTURE-INSTANCE" - "%MAKE-STRUCTURE-INSTANCE-ALLOCATOR" - "%MAP" "%MAP-FOR-EFFECT-ARITY-1" - "%MAP-TO-LIST-ARITY-1" "%MAP-TO-SIMPLE-VECTOR-ARITY-1" - "%MASK-FIELD" - "%MEMBER" - "%MEMBER-EQ" - "%MEMBER-IF" - "%MEMBER-IF-KEY" - "%MEMBER-IF-NOT" - "%MEMBER-IF-NOT-KEY" - "%MEMBER-KEY" - "%MEMBER-KEY-EQ" - "%MEMBER-KEY-TEST" - "%MEMBER-KEY-TEST-NOT" - "%MEMBER-TEST" - "%MEMBER-TEST-NOT" - "%MULTIPLY-HIGH" "%SIGNED-MULTIPLY-HIGH" - "%NEGATE" "%POW" - "%OTHER-POINTER-WIDETAG" - "%PCL-INSTANCE-P" - "%PUTHASH" - "%RASSOC" - "%RASSOC-EQ" - "%RASSOC-IF" - "%RASSOC-IF-KEY" - "%RASSOC-IF-NOT" - "%RASSOC-IF-NOT-KEY" - "%RASSOC-KEY" - "%RASSOC-KEY-EQ" - "%RASSOC-KEY-TEST" - "%RASSOC-KEY-TEST-NOT" - "%RASSOC-TEST" - "%RASSOC-TEST-NOT" - "%VECTOR-RAW-BITS" - "%SCALB" "%SCALBN" - "%RAW-INSTANCE-ATOMIC-INCF/WORD" - "%RAW-INSTANCE-CAS/WORD" - "%RAW-INSTANCE-REF/WORD" "%RAW-INSTANCE-SET/WORD" - "%RAW-INSTANCE-CAS/SIGNED-WORD" - "%RAW-INSTANCE-REF/SIGNED-WORD" "%RAW-INSTANCE-SET/SIGNED-WORD" - "%RAW-INSTANCE-REF/SINGLE" "%RAW-INSTANCE-SET/SINGLE" - "%RAW-INSTANCE-REF/DOUBLE" "%RAW-INSTANCE-SET/DOUBLE" - "%RAW-INSTANCE-REF/COMPLEX-SINGLE" - "%RAW-INSTANCE-SET/COMPLEX-SINGLE" - "%RAW-INSTANCE-REF/COMPLEX-DOUBLE" - "%RAW-INSTANCE-SET/COMPLEX-DOUBLE" - "ROUND-DOUBLE" "ROUND-SINGLE" - "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-INFO" - "%SET-VECTOR-RAW-BITS" - "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64" - "%SET-SAP-REF-WORD" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE" - "%SET-SAP-REF-LISPOBJ" "%SET-SAP-REF-LONG" "%SET-SAP-REF-SAP" - "%SET-SAP-REF-SINGLE" "%SET-SIGNED-SAP-REF-16" - "%SET-SIGNED-SAP-REF-32" "%SET-SIGNED-SAP-REF-64" - "%SET-SIGNED-SAP-REF-WORD" - "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF" - "%SET-SYMBOL-HASH" - "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT" - "%SINH" "%SQRT" - "%SXHASH-BIT-VECTOR" "%SXHASH-SIMPLE-BIT-VECTOR" - "%SXHASH-STRING" "%SXHASH-SIMPLE-STRING" - #+sb-simd-pack - ("%SIMD-PACK-TAG" - "%SIMD-PACK-LOW" - "%SIMD-PACK-HIGH") - #+sb-simd-pack-256 - ("%SIMD-PACK-256-TAG" - "%SIMD-PACK-256-0" "%SIMD-PACK-256-1" - "%SIMD-PACK-256-2" "%SIMD-PACK-256-3") - "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH" - "THE*" - "%UNARY-ROUND" - "%UNARY-TRUNCATE" - "%UNARY-TRUNCATE/SINGLE-FLOAT" - "%UNARY-TRUNCATE/DOUBLE-FLOAT" - "%UNARY-FTRUNCATE" - "%WITH-ARRAY-DATA" - "%WITH-ARRAY-DATA/FP" - "%WITH-ARRAY-DATA-MACRO" - "*APPROXIMATE-NUMERIC-UNIONS*" - "*CURRENT-INTERNAL-ERROR-CONTEXT*" - "*CURRENT-LEVEL-IN-PRINT*" - "*EMPTY-TYPE*" - "*EVAL-CALLS*" - "*GC-INHIBIT*" "*GC-PENDING*" - "*GC-PIN-CODE-PAGES*" - #+sb-thread "*STOP-FOR-GC-PENDING*" - "*IN-WITHOUT-GCING*" - "*UNIVERSAL-TYPE*" - "*UNIVERSAL-FUN-TYPE*" "*UNPARSE-FUN-TYPE-SIMPLIFY*" - "*WILD-TYPE*" "WORD-LOGICAL-AND" "WORD-LOGICAL-ANDC1" - "WORD-LOGICAL-ANDC2" "WORD-LOGICAL-EQV" - "WORD-LOGICAL-NAND" "WORD-LOGICAL-NOR" "WORD-LOGICAL-NOT" - "WORD-LOGICAL-OR" "WORD-LOGICAL-ORC1" "WORD-LOGICAL-ORC2" - "WORD-LOGICAL-XOR" - "ALLOW-NON-RETURNING-TAIL-CALL" - "ALIEN-TYPE-TYPE" "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" - "ALLOCATE-VECTOR" "ALLOCATE-STATIC-VECTOR" - "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" - "BUILD-RATIO" - "PROGRAM-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" - "DISABLED-PACKAGE-LOCKS" - "WITH-SINGLE-PACKAGE-LOCKED-ERROR" - "ALWAYS-SUBTYPEP" - "ARGS-TYPE" "ARGS-TYPE-ALLOWP" "ARGS-TYPE-KEYP" - "ARGS-TYPE-KEYWORDS" "ARGS-TYPE-OPTIONAL" "ARGS-TYPE-P" - "ARGS-TYPE-REQUIRED" "ARGS-TYPE-REST" - "ARRAY-HEADER-P" "SIMPLE-ARRAY-HEADER-P" - "ARRAY-TYPE" "ARRAY-TYPE-COMPLEXP" - "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE" - "ARRAY-TYPE-P" "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" - "ARRAY-UNDERLYING-WIDETAG" - "ASSERT-ERROR" - #+sb-unicode "BASE-CHAR-P" - "BASE-STRING-P" - "BIND" "BINDING-STACK-POINTER-SAP" "BIT-INDEX" - "BOGUS-ARG-TO-VALUES-LIST-ERROR" "BOOLE-CODE" - "BOUNDING-INDICES-BAD-ERROR" "BYTE-SPECIFIER" "%BYTE-BLT" - "FUNCTION-DESIGNATOR" - "CASE-BODY-ERROR" - "CHARACTER-SET" "CHARACTER-SET-TYPE" - "CHARACTER-SET-TYPE-PAIRS" - #+sb-unicode "CHARACTER-STRING-P" - "CHARPOS" - "CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR" "CLOSED-FLAME" - "CLASS-CLASSOID" - "CODE-COMPONENT" "CODE-COMPONENT-P" - "CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-HEADER-WORDS" - "CODE-JUMP-TABLE-WORDS" - "CODE-INSTRUCTIONS" "CODE-N-UNBOXED-DATA-BYTES" - "CODE-OBJECT-SIZE" "CODE-TRAILER-REF" - "COERCE-SYMBOL-TO-FUN" - "COERCE-TO-FUN" "COERCE-TO-LEXENV" "COERCE-TO-LIST" - "COERCE-TO-VALUES" "COERCE-TO-VECTOR" - "COMPLEX-DOUBLE-FLOAT" "COMPLEX-DOUBLE-FLOAT-P" - "COMPLEX-FLOAT-P" - #+long-float ("COMPLEX-LONG-FLOAT" "COMPLEX-LONG-FLOAT-P") - "COMPLEX-RATIONAL-P" - "COMPLEX-SINGLE-FLOAT" "COMPLEX-SINGLE-FLOAT-P" - "COMPLEX-VECTOR-P" "COMPOUND-TYPE" "COMPOUND-TYPE-P" - "COMPOUND-TYPE-TYPES" - "CONDITION-DESIGNATOR-HEAD" - "CONS-TYPE" "CONS-TYPE-CAR-TYPE" - "CONS-TYPE-CDR-TYPE" "CONS-TYPE-P" "CONSED-SEQUENCE" - "CONSTANT" "CONSTANT-TYPE" "CONSTANT-TYPE-P" - "CONSTANT-TYPE-TYPE" "CONTAINING-INTEGER-TYPE" - "CONTROL-STACK-POINTER-SAP" - "CSUBTYPEP" "CTYPE" "TYPE-HASH-VALUE" "CTYPE-OF" - "CTYPE-P" "CTYPEP" - "CTYPE-ARRAY-DIMENSIONS" "CTYPE-ARRAY-SPECIALIZED-ELEMENT-TYPES" - "CURRENT-FP" "CURRENT-SP" "CURRENT-DYNAMIC-SPACE-START" - "DATA-NIL-VECTOR-REF" - "DATA-VECTOR-REF" "DATA-VECTOR-REF-WITH-OFFSET" - "DATA-VECTOR-SET" "DATA-VECTOR-SET-WITH-OFFSET" - "DECLARATION-TYPE-CONFLICT-ERROR" - "DECODE-DOUBLE-FLOAT" - #+long-float "DECODE-LONG-FLOAT" - "DECODE-SINGLE-FLOAT" - "DEFINE-STRUCTURE-SLOT-ADDRESSOR" - "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P" - "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO" - "DIVISION-BY-ZERO-ERROR" - "DO-REST-ARG" - "DO-INSTANCE-TAGGED-SLOT" - "DOUBLE-FLOAT-EXPONENT" - "DOUBLE-FLOAT-BITS" - "DOUBLE-FLOAT-HIGH-BITS" "DOUBLE-FLOAT-INT-EXPONENT" - "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-SIGNIFICAND" - "DSD-ACCESSOR-NAME" "DSD-ALWAYS-BOUNDP" "DSD-DEFAULT" "DSD-INDEX" - "DSD-NAME" "DSD-RAW-TYPE" "DSD-READ-ONLY" "DSD-TYPE" - "DYNBIND" - "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE" - "EFFECTIVE-FIND-POSITION-TEST" - "EFFECTIVE-FIND-POSITION-KEY" - "ENSURE-SYMBOL-HASH" - "ENSURE-SYMBOL-TLS-INDEX" - "ERROR-NUMBER-OR-LOSE" - "EVAL-WHEN-COMPILE-TOPLEVEL" - "EXTENDED-CHAR-P" "EXTERNAL-FORMAT-DESIGNATOR" - "FAST-&REST-NTH" - "FILENAME" - "FILL-ARRAY" - "FILL-DATA-VECTOR" - "FIND-AND-INIT-OR-CHECK-LAYOUT" - "FIND-DEFSTRUCT-DESCRIPTION" - "FIND-OR-CREATE-FDEFN" - "FLOAT-EXPONENT" - "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME" - "FLOAT-FORMAT-MAX" "FLOAT-INT-EXPONENT" - "FLOAT-INFINITY-OR-NAN-P" - "FLOAT-SIGN-BIT" - "FLOATING-POINT-EXCEPTION" "FORM" "FORMAT-CONTROL" - "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P" - "FSC-INSTANCE-HASH" - "%FUN-CODE-OFFSET" "FUN-CODE-HEADER" - "FUN-DESIGNATOR-TYPE" "FUN-DESIGNATOR-TYPE-P" - "FUN-TYPE" "FUN-TYPE-ALLOWP" - "FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS" "FUN-TYPE-NARGS" - "FUN-TYPE-OPTIONAL" "FUN-TYPE-P" "FUN-TYPE-REQUIRED" - "FUN-TYPE-REST" "FUN-TYPE-RETURNS" "FUN-TYPE-WILD-ARGS" - "GENERALIZED-BOOLEAN" - "GENERIC-ABSTRACT-TYPE-FUNCTION" - "GET-CLOSURE-LENGTH" "GET-HEADER-DATA" - "FUNCTION-HEADER-WORD" - "INSTANCE-HEADER-WORD" - "GET-LISP-OBJ-ADDRESS" "GENERATION-OF" - "LOWTAG-OF" "WIDETAG-OF" "WIDETAG=" - "HAIRY-DATA-VECTOR-REF" - "HAIRY-DATA-VECTOR-REF/CHECK-BOUNDS" "HAIRY-DATA-VECTOR-SET" - "HAIRY-DATA-VECTOR-SET/CHECK-BOUNDS" - "HAIRY-TYPE" "HAIRY-TYPE-P" "HAIRY-TYPE-SPECIFIER" - "HANDLE-CIRCULARITY" "HOST" "ILL-BIN" - "ILL-BOUT" "ILL-IN" "ILL-OUT" "INDEX-OR-MINUS-1" - "INDEX-TOO-LARGE-ERROR" "*!INITIAL-ASSEMBLER-ROUTINES*" - "*!INITIAL-DEBUG-SOURCES*" - "*!INITIAL-FDEFN-OBJECTS*" "*!INITIAL-FOREIGN-SYMBOLS*" - "*!INITIAL-LAYOUTS*" "*!INITIAL-SYMBOLS*" - "INTEGER-DECODE-DOUBLE-FLOAT" - #+long-float "INTEGER-DECODE-LONG-FLOAT" - "INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-ERROR" - #+win32 "HANDLE-WIN32-EXCEPTION" - "INTERNAL-TIME" "INTERNAL-SECONDS" - "INTERNAL-SECONDS-LIMIT" "SAFE-INTERNAL-SECONDS-LIMIT" - "INTERPRETED-FUNCTION" - "INTERSECTION-TYPE" "INTERSECTION-TYPE-P" - "INTERSECTION-TYPE-TYPES" "INVALID-ARG-COUNT-ERROR" - "LOCAL-INVALID-ARG-COUNT-ERROR" - "INVALID-UNWIND-ERROR" - "IRRATIONAL" "KEY-INFO" - "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" - "LAYOUT-BITMAP" "LAYOUT-BITMAP-WORDS" "LAYOUT-CLASSOID-NAME" - "LAYOUT-DEPTHOID" "LAYOUT-EQUALP-IMPL" - "LAYOUT-ID" - "LAYOUT-FOR-PCL-OBJ-P" - "LAYOUT-SLOT-LIST" "LAYOUT-SLOT-TABLE" - #+(or x86-64 x86) "%LEA" - "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" - "LIST-ABSTRACT-TYPE-FUNCTION" - "LIST-COPY-SEQ*" - "LIST-FILL*" - "LIST-SUBSEQ*" - "ANSI-STREAM" - "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE" - "ANSI-STREAM-IN" - "ANSI-STREAM-IN-BUFFER" "ANSI-STREAM-IN-INDEX" - "ANSI-STREAM-MISC" - "ANSI-STREAM-N-BIN" - "ANSI-STREAM-OUT" "ANSI-STREAM-SOUT" - "COMPLEX-VECTOR" - "LIST-TO-VECTOR*" - "LOGICAL-HOST" "LOGICAL-HOST-DESIGNATOR" - #+long-float ("LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS" - "LONG-FLOAT-HIGH-BITS""LONG-FLOAT-LOW-BITS" - "LONG-FLOAT-MID-BITS") - "LRA" "LRA-CODE-HEADER" "LRA-P" - "MAKE-ALIEN-TYPE-TYPE" - "MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-CONS-TYPE" - "%MAKE-DOUBLE-FLOAT" - "MAKE-DOUBLE-FLOAT" "MAKE-FUN-TYPE" "MAKE-KEY-INFO" - "MAKE-LISP-OBJ" - #+long-float "MAKE-LONG-FLOAT" - "MAKE-MEMBER-TYPE" "MAKE-NULL-LEXENV" - "MAKE-EQL-TYPE" "MEMBER-TYPE-FROM-LIST" - "MAKE-NEGATION-TYPE" "TYPE-NEGATION" - "MAKE-NUMERIC-TYPE" - "MAKE-SINGLE-FLOAT" - "MAKE-UNBOUND-MARKER" - "MAKE-SHORT-VALUES-TYPE" "MAKE-SINGLE-VALUE-TYPE" - "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE" - "MAPC-MEMBER-TYPE-MEMBERS" "MAPCAR-MEMBER-TYPE-MEMBERS" - "MAXIMUM-BIGNUM-LENGTH" - "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" - "MEMBER-TYPE-SIZE" - "MODIFIED-NUMERIC-TYPE" - "MOST-NEGATIVE-EXACTLY-DOUBLE-FLOAT-FIXNUM" - "MOST-NEGATIVE-EXACTLY-SINGLE-FLOAT-FIXNUM" - "MOST-POSITIVE-EXACTLY-DOUBLE-FLOAT-FIXNUM" - "MOST-POSITIVE-EXACTLY-SINGLE-FLOAT-FIXNUM" - "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P" - "NEGATE" "NEGATION-TYPE" "NEGATION-TYPE-TYPE" - "NIL-ARRAY-ACCESSED-ERROR" - "NIL-FUN-RETURNED-ERROR" - "NON-NULL-SYMBOL-P" - "NUMERIC-CONTAGION" "NUMERIC-TYPE" - "NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP" - "NUMERIC-TYPE-EQUAL" "NUMERIC-TYPE-FORMAT" - "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P" - "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-CHARACTER-ERROR" - "OBJECT-NOT-BASE-STRING-ERROR" "OBJECT-NOT-BIGNUM-ERROR" - "OBJECT-NOT-BIT-VECTOR-ERROR" - #+sb-unicode "OBJECT-NOT-CHARACTER-STRING-ERROR" - "OBJECT-NOT-COMPLEX-ERROR" - "OBJECT-NOT-COMPLEX-FLOAT-ERROR" - "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR" - #+long-float "OBJECT-NOT-COMPLEX-LONG-FLOAT-ERROR" - "OBJECT-NOT-COMPLEX-DOUBLE-FLOAT-ERROR" - "OBJECT-NOT-COMPLEX-RATIONAL-ERROR" - ;; FIXME: It's confusing using "complex" to mean both - ;; "not on the real number line" and "not of a - ;; SIMPLE-ARRAY nature". Perhaps we could rename all the - ;; uses in the second sense as "hairy" instead? - "OBJECT-NOT-COMPLEX-VECTOR-ERROR" "OBJECT-NOT-CONS-ERROR" - "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR" - "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR" - "OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-INTEGER-ERROR" - "OBJECT-NOT-LIST-ERROR" - #+long-float "OBJECT-NOT-LONG-FLOAT-ERROR" - "OBJECT-NOT-NUMBER-ERROR" "OBJECT-NOT-RATIO-ERROR" - "OBJECT-NOT-RATIONAL-ERROR" "OBJECT-NOT-REAL-ERROR" - "OBJECT-NOT-SAP-ERROR" "OBJECT-NOT-SIGNED-BYTE-32-ERROR" - "OBJECT-NOT-SIGNED-BYTE-64-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR" - #+long-float - "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR" - #+sb-simd-pack - "OBJECT-NOT-SIMD-PACK-ERROR" - #+sb-simd-pack-256 - "OBJECT-NOT-SIMD-PACK-256-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-ERROR" - #+long-float "OBJECT-NOT-SIMPLE-ARRAY-LONG-FLOAT-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-NIL-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-SINGLE-FLOAT-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-15-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-16-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-2-ERROR" - ;; KLUDGE: 32-bit and 64-bit ports implement a different - ;; set of specialized array types. Various bits of code - ;; in SBCL assume that symbols connected to the - ;; specialized array types are exported. But there's not - ;; a good way at this point to know whether the port for - ;; which we're building is 32-bit or 64-bit. Granted, we - ;; could hardcode the particulars (or even come up with a - ;; special :64BIT feature), but that seems a little - ;; inelegant. For now, we brute-force the issue by - ;; always exporting all the names required for both - ;; 32-bit and 64-bit ports. Other bits connected to the - ;; same issue are noted throughout the code below with - ;; the tag "32/64-bit issues". --njf, 2004-08-09 - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-FIXNUM-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-31-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-4-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-63-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-64-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-7-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-8-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-16-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-FIXNUM-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-32-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-64-ERROR" - "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-8-ERROR" - "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR" - "OBJECT-NOT-SIMPLE-BASE-STRING-ERROR" - #+sb-unicode "OBJECT-NOT-SIMPLE-CHARACTER-STRING-ERROR" - "OBJECT-NOT-SIMPLE-STRING-ERROR" - "OBJECT-NOT-SIMPLE-VECTOR-ERROR" - "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR" - "OBJECT-NOT-SYMBOL-ERROR" - "OBJECT-NOT-TYPE-ERROR" - "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR" - "OBJECT-NOT-UNSIGNED-BYTE-64-ERROR" - "OBJECT-NOT-VECTOR-ERROR" - "OBJECT-NOT-VECTOR-NIL-ERROR" - "OBJECT-NOT-WEAK-POINTER-ERROR" - "ODD-KEY-ARGS-ERROR" "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT" - "PACKAGE-DESIGNATOR" "PACKAGE-DOC-STRING" - "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE" - "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS" - "PARSE-UNKNOWN-TYPE" - "PARSE-UNKNOWN-TYPE-SPECIFIER" - "PATHNAME-DESIGNATOR" "PATHNAME-COMPONENT-CASE" - "POINTER-HASH" - "POINTERP" - #+(or x86 x86-64) "*PSEUDO-ATOMIC-BITS*" - "PUNT-PRINT-IF-TOO-LONG" - "RANDOM-DOCUMENTATION" - "READER-IMPOSSIBLE-NUMBER-ERROR" - "READER-EOF-ERROR" - "RESTART-DESIGNATOR" - "RUN-PENDING-FINALIZERS" - "SCALE-DOUBLE-FLOAT" - #+long-float "SCALE-LONG-FLOAT" - "SCALE-SINGLE-FLOAT" - "SCHWARTZIAN-STABLE-SORT-LIST" "SCHWARTZIAN-STABLE-SORT-VECTOR" - "SCRUB-POWER-CACHE" - "SEQUENCEP" "SEQUENCE-COUNT" "SEQUENCE-END" - "SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE" - "SET-ARRAY-HEADER" "SET-HEADER-BITS" "SET-HEADER-DATA" - "UNSET-HEADER-BITS" "TEST-HEADER-BIT" - "SHIFT-TOWARDS-END" - "SHIFT-TOWARDS-START" "SHRINK-VECTOR" "%SHRINK-VECTOR" - "SIGNED-BYTE-32-P" "SIGNED-BYTE-64-P" - "SIMPLE-RANK-1-ARRAY-*-P" - "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-P" - #+long-float "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-P" - "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-P" - "SIMPLE-ARRAY-DOUBLE-FLOAT-P" - #+long-float "SIMPLE-ARRAY-LONG-FLOAT-P" - "SIMPLE-ARRAY-NIL-P" "SIMPLE-ARRAY-P" - "SIMPLE-ARRAY-SINGLE-FLOAT-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-15-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-16-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-2-P" - "SIMPLE-ARRAY-UNSIGNED-FIXNUM-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-31-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-32-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-4-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-63-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-64-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-7-P" - "SIMPLE-ARRAY-UNSIGNED-BYTE-8-P" - "SIMPLE-ARRAY-SIGNED-BYTE-16-P" - "SIMPLE-ARRAY-FIXNUM-P" - "SIMPLE-ARRAY-SIGNED-BYTE-32-P" - "SIMPLE-ARRAY-SIGNED-BYTE-64-P" - "SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-BASE-STRING-P" - "SIMPLE-CHARACTER-STRING" - #+sb-unicode "SIMPLE-CHARACTER-STRING-P" - "SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY" - "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT" - "SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-SIGNIFICAND" - "SINGLE-FLOAT-SIGN" "SINGLE-FLOAT-COPYSIGN" - "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE" - "SPECIFIER-TYPE" - #+sb-simd-pack("SIMD-PACK-SINGLE" - "SIMD-PACK-DOUBLE" - "SIMD-PACK-INT" - "SIMD-PACK-TYPE" - "SIMD-PACK-TYPE-ELEMENT-TYPE" - "*SIMD-PACK-ELEMENT-TYPES*") - #+sb-simd-pack-256("SIMD-PACK-256-SINGLE" - "SIMD-PACK-256-DOUBLE" - "SIMD-PACK-256-INT" - "SIMD-PACK-256-TYPE" - "SIMD-PACK-256-TYPE-ELEMENT-TYPE") - "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR" - "STRING-FILL*" - "STRUCT-SLOT-SAP" - "STRUCTURE-CTOR-LAMBDA-PARTS" - "STRUCTURE-INSTANCE-ACCESSOR-P" - "SUB-GC" - "SYMBOL-TLS-INDEX" - "SYMBOLS-DESIGNATOR" - "SYMEVAL" - "SYM-GLOBAL-VAL" - "%INSTANCE-LENGTH" - "%INSTANCE-REF" "%INSTANCE-REF-EQ" - "%INSTANCE-SET" - "TESTABLE-TYPE-P" - "TLS-EXHAUSTED-ERROR" - "*TOP-LEVEL-FORM-P*" - "TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/" - "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-=" - "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-EQV" - "TWO-ARG-GCD" "TWO-ARG-IOR" "TWO-ARG-LCM" "TWO-ARG-XOR" - "TWO-ARG-STRING=" "TWO-ARG-STRING-EQUAL" "TWO-ARG-STRING<" - "TWO-ARG-STRING>" "TWO-ARG-STRING<=" "TWO-ARG-STRING>=" - "TWO-ARG-STRING/=" "TWO-ARG-STRING-LESSP" "TWO-ARG-STRING-GREATERP" - "TWO-ARG-STRING-NOT-LESSP" "TWO-ARG-STRING-NOT-GREATERP" "TWO-ARG-STRING-NOT-EQUAL" - "TYPE-*-TO-T" - "TYPE-DIFFERENCE" "TYPE-INTERSECTION" - "TYPE-INTERSECTION2" "TYPE-APPROX-INTERSECTION2" - "TYPE-SINGLETON-P" - "TYPE-SINGLE-VALUE-P" "TYPE-SPECIFIER" "TYPE-UNION" - "TYPE/=" "TYPE=" "TYPES-EQUAL-OR-INTERSECT" - "TYPE-OR-NIL-IF-UNKNOWN" - "TYPE-ERROR-DATUM-STORED-TYPE" - "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY" - "UNDEFINED-FUN-ERROR" "UNDEFINED-ALIEN-FUN-ERROR" - "UNION-TYPE" "UNION-TYPE-P" - "UNION-TYPE-TYPES" "UNKNOWN-ERROR" - "UNINITIALIZED-MEMORY-ERROR" - "UNKNOWN-KEY-ARG-ERROR" "UNKNOWN-TYPE" "UNKNOWN-TYPE-P" - "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR" - "UNSIGNED-BYTE-32-P" "UNSIGNED-BYTE-64-P" - "UPDATE-OBJECT-LAYOUT" - "VALID-MACROEXPAND-HOOK" - "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-SPECIFIER-TYPE" - "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP" - "VALUES-TYPE" "VALUES-TYPE-IN" - "VALUES-TYPE-INTERSECTION" - "VALUES-TYPE-MIN-VALUE-COUNT" "VALUES-TYPE-MAX-VALUE-COUNT" - "VALUES-TYPE-MAY-BE-SINGLE-VALUE-P" "VALUES-TYPE-OPTIONAL" - "VALUES-TYPE-OUT" "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED" - "VALUES-TYPE-REST" "VALUES-TYPE-UNION" - "VALUES-TYPE-TYPES" "VALUES-TYPES" - "VALUES-TYPES-EQUAL-OR-INTERSECT" - - "*VECTOR-WITHOUT-COMPLEX-TYPECODE-INFOS*" - "VECTOR-SINGLE-FLOAT-P" "VECTOR-DOUBLE-FLOAT-P" - "VECTOR-UNSIGNED-BYTE-2-P" "VECTOR-UNSIGNED-BYTE-4-P" - "VECTOR-UNSIGNED-BYTE-7-P" "VECTOR-UNSIGNED-BYTE-8-P" - "VECTOR-UNSIGNED-BYTE-15-P" "VECTOR-UNSIGNED-BYTE-16-P" - "VECTOR-UNSIGNED-BYTE-31-P" "VECTOR-UNSIGNED-BYTE-32-P" - "VECTOR-UNSIGNED-BYTE-63-P" "VECTOR-UNSIGNED-BYTE-64-P" - "VECTOR-SIGNED-BYTE-8-P" "VECTOR-SIGNED-BYTE-16-P" - "VECTOR-FIXNUM-P" "VECTOR-SIGNED-BYTE-32-P" - "VECTOR-SIGNED-BYTE-64-P" "VECTOR-COMPLEX-SINGLE-FLOAT-P" - "VECTOR-COMPLEX-DOUBLE-FLOAT-P" "VECTOR-T-P" - - "VECTOR-NIL-P" - "VECTOR-FILL*" "VECTOR-FILL/T" - "VECTOR-SUBSEQ*" - "VECTOR-TO-VECTOR*" - "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" "WITH-ARRAY-DATA" - "WITH-CIRCULARITY-DETECTION" - "WITH-WORLD-LOCK" - - ;; bit bash fillers - "UB1-BASH-FILL" "SYSTEM-AREA-UB1-FILL" - "UB2-BASH-FILL" "SYSTEM-AREA-UB2-FILL" - "UB4-BASH-FILL" "SYSTEM-AREA-UB4-FILL" - "UB8-BASH-FILL" "SYSTEM-AREA-UB8-FILL" - "UB16-BASH-FILL" "SYSTEM-AREA-UB16-FILL" - "UB32-BASH-FILL" "SYSTEM-AREA-UB32-FILL" - "UB64-BASH-FILL" "SYSTEM-AREA-UB64-FILL" - - "UB1-BASH-FILL-WITH-UB1" "UB1-BASH-FILL-WITH-SB1" - "UB2-BASH-FILL-WITH-UB2" "UB2-BASH-FILL-WITH-SB2" - "UB4-BASH-FILL-WITH-UB4" "UB4-BASH-FILL-WITH-SB4" - "UB8-BASH-FILL-WITH-UB8" "UB8-BASH-FILL-WITH-SB8" - "UB16-BASH-FILL-WITH-UB16" "UB16-BASH-FILL-WITH-SB16" - "UB32-BASH-FILL-WITH-UB32" "UB32-BASH-FILL-WITH-SB32" - "UB64-BASH-FILL-WITH-SB64" - "UB32-BASH-FILL-WITH-FIXNUM" "UB64-BASH-FILL-WITH-FIXNUM" - "UB32-BASH-FILL-WITH-SINGLE-FLOAT" - "UB64-BASH-FILL-WITH-DOUBLE-FLOAT" - "UB64-BASH-FILL-WITH-COMPLEX-SINGLE-FLOAT" - - ;; bit bash copiers - "UB1-BASH-COPY" "SYSTEM-AREA-UB1-COPY" - "COPY-UB1-TO-SYSTEM-AREA" "COPY-UB1-FROM-SYSTEM-AREA" - "UB2-BASH-COPY" "SYSTEM-AREA-UB2-COPY" - "COPY-UB2-TO-SYSTEM-AREA" "COPY-UB2-FROM-SYSTEM-AREA" - "UB4-BASH-COPY" "SYSTEM-AREA-UB4-COPY" - "COPY-UB4-TO-SYSTEM-AREA" "COPY-UB4-FROM-SYSTEM-AREA" - "UB8-BASH-COPY" "SYSTEM-AREA-UB8-COPY" - "COPY-UB8-TO-SYSTEM-AREA" "COPY-UB8-FROM-SYSTEM-AREA" - "UB16-BASH-COPY" "SYSTEM-AREA-UB16-COPY" - "COPY-UB16-TO-SYSTEM-AREA" "COPY-UB16-FROM-SYSTEM-AREA" - "UB32-BASH-COPY" "SYSTEM-AREA-UB32-COPY" - "COPY-UB32-TO-SYSTEM-AREA" "COPY-UB32-FROM-SYSTEM-AREA" - "UB64-BASH-COPY" "SYSTEM-AREA-UB64-COPY" - "COPY-UB64-TO-SYSTEM-AREA" "COPY-UB64-FROM-SYSTEM-AREA" - - ;; Bit bashing position for bit-vectors - "%BIT-POSITION" "%BIT-POS-FWD" "%BIT-POS-REV" - "%BIT-POSITION/0" "%BIT-POS-FWD/0" "%BIT-POS-REV/0" - "%BIT-POSITION/1" "%BIT-POS-FWD/1" "%BIT-POS-REV/1" - - ;; SIMPLE-FUN type and accessors - "SIMPLE-FUN" - "SIMPLE-FUN-P" - "%SIMPLE-FUN-ARGLIST" - "%SIMPLE-FUN-DOC" - "%SIMPLE-FUN-INFO" - "%SIMPLE-FUN-LEXPR" - "%SIMPLE-FUN-NAME" - "%SIMPLE-FUN-NEXT" ; FIXME: remove - "%SIMPLE-FUN-SELF" ; FIXME: don't export - "%SIMPLE-FUN-TEXT-LEN" - "%SIMPLE-FUN-SOURCE" - "%SIMPLE-FUN-TYPE" - "%SIMPLE-FUN-XREFS" - - ;; CLOSURE type and accessors - "CLOSURE" - "CLOSUREP" - "DO-CLOSURE-VALUES" - "%CLOSURE-FUN" - "%CLOSURE-INDEX-REF" - "%CLOSURE-VALUES" - - ;; Abstract function accessors - "%FUN-FUN" - "%FUN-LAMBDA-LIST" - "%FUN-NAME" - - "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUN" - "FDEFN-MAKUNBOUND" - "%COERCE-CALLABLE-TO-FUN" - "%COERCE-CALLABLE-FOR-CALL" - "FUN-SUBTYPE" - "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST" - "INFINITE-ERROR-PROTECT" - "FIND-CALLER-OF-NAMED-FRAME" - "FIND-CALLER-FRAME" - "FIND-INTERRUPTED-FRAME" - "%SET-SYMBOL-VALUE" "%SET-SYMBOL-GLOBAL-VALUE" "%SET-SYMBOL-PACKAGE" - "SET-SYMBOL-GLOBAL-VALUE" - "OUTPUT-SYMBOL" "%COERCE-NAME-TO-FUN" - "DEFAULT-STRUCTURE-PRINT" - "LAYOUT" "LAYOUT-LENGTH" "LAYOUT-PURE" - "DEFSTRUCT-DESCRIPTION" "UNDECLARE-STRUCTURE" - "UNDEFINE-FUN-NAME" "DD-TYPE" "CLASSOID-STATE" "INSTANCE" - "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" - "%TYPEP" "%%TYPEP" "DD-NAME" "CLASSOID-SUBCLASSES" - "CLASSOID-LAYOUT" "CLASSOID-NAME" "CLASSOID-P" - "NOTE-NAME-DEFINED" - "%CODE-CODE-SIZE" "%CODE-TEXT-SIZE" - "%CODE-SERIALNO" - "DD-SLOTS" "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM" - "SLOT-ACCESS-TRANSFORM" - "%IMAGPART" "%CODE-DEBUG-INFO" - "LAYOUT-CLASSOID" "LAYOUT-INVALID" - "LAYOUT-FLAGS" - "%INSTANCEP" "DEFSTRUCT-SLOT-DESCRIPTION" - "DD-PREDICATE-NAME" - "CLASSOID-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO" - "LAYOUT-DD" - "%SET-INSTANCE-LAYOUT" - "DD-CONSTRUCTORS" "DD-DEFAULT-CONSTRUCTOR" - "LAYOUT-OF" "%REALPART" - "STRUCTURE-CLASSOID" "STRUCTURE-CLASSOID-P" - "GET-DSD-INDEX" - "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" - "PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME" - "%NUMERATOR" "CLASSOID-TYPEP" - "LAYOUT-INHERITS" "DD-LENGTH" - "SET-LAYOUT-INHERITS" - "%CODE-ENTRY-POINT" - "%CODE-FUN-OFFSET" - "CODE-N-ENTRIES" - "CODE-N-NAMED-CALLS" - "CODE-OBJ-IS-FILLER-P" - "%DENOMINATOR" - "%OTHER-POINTER-P" - "%OTHER-POINTER-SUBTYPE-P" - "IMMOBILE-SPACE-ADDR-P" - "IMMOBILE-SPACE-OBJ-P" - - "STANDARD-CLASSOID" "CLASSOID-OF" - "MAKE-STANDARD-CLASSOID" - "CLASSOID-CELL-CLASSOID" - "CLASSOID-CELL-NAME" - "CLASSOID-CELL-PCL-CLASS" - "CLASSOID-CELL-TYPEP" - "%CLEAR-CLASSOID" - "FIND-CLASSOID-CELL" - "%RANDOM-DOUBLE-FLOAT" - #+long-float "%RANDOM-LONG-FLOAT" - "%RANDOM-SINGLE-FLOAT" "STATIC-CLASSOID" - "%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK" "BIG-RANDOM-CHUNK" - "N-RANDOM-CHUNK-BITS" - "LAYOUT-CLOS-HASH-LIMIT" - "BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES" - "BUILT-IN-CLASSOID-TRANSLATION" "HASH-LAYOUT-NAME" - "CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE" - "FUNCTION-WITH-LAYOUT-P" - "%FUN-LAYOUT" - "%SET-FUNCALLABLE-INSTANCE-LAYOUT" - "REGISTER-LAYOUT" - "FUNCALLABLE-INSTANCE" - "MAKE-STATIC-CLASSOID" - "%MAKE-SYMBOL" - "%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH" "SYMBOL-HASH*" - "SYMBOL-INFO" "SYMBOL-INFO-VECTOR" - - "EXTENDED-SEQUENCE" "*EXTENDED-SEQUENCE-TYPE*" - "EXTENDED-SEQUENCE-P" - - "BUILT-IN-CLASSOID" "CONDITION-CLASSOID-P" - "CONDITION-CLASSOID-SLOTS" "MAKE-UNDEFINED-CLASSOID" - "FIND-CLASSOID" "CLASSOID" "CLASSOID-DIRECT-SUPERCLASSES" - "MAKE-LAYOUT" "REDEFINE-LAYOUT-WARNING" - "INSURED-FIND-CLASSOID" "ORDER-LAYOUT-INHERITS" - "STD-COMPUTE-CLASS-PRECEDENCE-LIST" - "+CTYPE-LAYOUT-FLAG+" - "+STRUCTURE-LAYOUT-FLAG+" - "+PCL-OBJECT-LAYOUT-FLAG+" - "+CONDITION-LAYOUT-FLAG+" - "+PATHNAME-LAYOUT-FLAG+" - "+STREAM-LAYOUT-FLAG+" - "+SIMPLE-STREAM-LAYOUT-FLAG+" - "+FILE-STREAM-LAYOUT-FLAG+" - "+STRING-STREAM-LAYOUT-FLAG+" - "+LAYOUT-ALL-TAGGED+" - "**PRIMITIVE-OBJECT-LAYOUTS**" - - "*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*" - "WITH-SIMPLE-CONDITION-RESTARTS" - "CASE-FAILURE" "ECASE-FAILURE" "ETYPECASE-FAILURE" - "NAMESTRING-PARSE-ERROR" - "NAMESTRING-PARSE-ERROR-OFFSET" - "NO-NAMESTRING-ERROR" "NO-NATIVE-NAMESTRING-ERROR" - "MAKE-RESTART" "RESTART-ASSOCIATED-CONDITIONS" - "COERCE-TO-CONDITION" - - "ALLOCATE-CONDITION" - - "CONDITION-SLOT-VALUE" - "SET-CONDITION-SLOT-VALUE" - - "CONDITION-SLOT-ALLOCATION" - "CONDITION-SLOT-DOCUMENTATION" - "CONDITION-SLOT-INITARGS" - "CONDITION-SLOT-INITFORM" - "CONDITION-SLOT-INITFORM-P" - "CONDITION-SLOT-INITFUNCTION" - "CONDITION-SLOT-NAME" "CONDITION-SLOT-READERS" - "CONDITION-SLOT-WRITERS" - - "REDEFINITION-WARNING" - "REDEFINITION-WITH-DEFUN" - "REDEFINITION-WITH-DEFMACRO" - "REDEFINITION-WITH-DEFGENERIC" - "REDEFINITION-WITH-DEFMETHOD" - "UNINTERESTING-ORDINARY-FUNCTION-REDEFINITION-P" - "UNINTERESTING-GENERIC-FUNCTION-REDEFINITION-P" - "UNINTERESTING-METHOD-REDEFINITION-P" - "UNINTERESTING-REDEFINITION" - "REDEFINITION-WITH-DEFTRANSFORM" - - "DUBIOUS-ASTERISKS-AROUND-VARIABLE-NAME" - "ASTERISKS-AROUND-LEXICAL-VARIABLE-NAME" - "ASTERISKS-AROUND-CONSTANT-VARIABLE-NAME" - "&OPTIONAL-AND-&KEY-IN-LAMBDA-LIST" - "UNDEFINED-ALIEN-STYLE-WARNING" - "LEXICAL-ENVIRONMENT-TOO-COMPLEX" - "CHARACTER-DECODING-ERROR-IN-COMMENT" - "DEPRECATED-EVAL-WHEN-SITUATIONS" - "PROCLAMATION-MISMATCH" - "PROCLAMATION-MISMATCH-NAME" - "PROCLAMATION-MISMATCH-NEW" - "PROCLAMATION-MISMATCH-OLD" - "TYPE-PROCLAMATION-MISMATCH" - "TYPE-PROCLAMATION-MISMATCH-WARNING" - "TYPE-PROCLAMATION-MISMATCH-WARN" - "FTYPE-PROCLAMATION-MISMATCH" - "FTYPE-PROCLAMATION-MISMATCH-WARNING" - "FTYPE-PROCLAMATION-MISMATCH-WARN" - "FTYPE-PROCLAMATION-MISMATCH-ERROR" - - "!COLD-INIT" - "!GLOBALDB-COLD-INIT" - "!FOREIGN-COLD-INIT" - "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT" - "!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT" - "!DEADLINE-COLD-INIT" - "!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT" - "!FIXUP-TYPE-COLD-INIT" "!TARGET-TYPE-COLD-INIT" - "!RANDOM-COLD-INIT" "!READER-COLD-INIT" - "!PATHNAME-COLD-INIT" "!DEBUG-INFO-COLD-INIT" - "!TYPECHECKFUNS-COLD-INIT" "!LOADER-COLD-INIT" - "!EXHAUST-COLD-INIT" "!PACKAGE-COLD-INIT" - "!POLICY-COLD-INIT-OR-RESANIFY" - "!VM-TYPE-COLD-INIT" "!BACKQ-COLD-INIT" - "!SHARPM-COLD-INIT" "!EARLY-PROCLAIM-COLD-INIT" - "!LATE-PROCLAIM-COLD-INIT" "!CLASS-FINALIZE" - "!CONSTANTP-COLD-INIT" "!CONSTANTP2-COLD-INIT" - "!WORLD-LOCK-COLD-INIT" - - "FLOAT-COLD-INIT-OR-REINIT" - "GC-REINIT" - "TIME-REINIT" - "SIGNAL-COLD-INIT-OR-REINIT" - "STREAM-COLD-INIT-OR-RESET" - - ;; Cleanups to run before saving a core - "FLOAT-DEINIT" - "FOREIGN-DEINIT" - "PROFILE-DEINIT" - - ;; Note: These are out of lexicographical order - ;; because in CMU CL they were defined as - ;; internal symbols in package "CL" imported - ;; into package "C", as opposed to what we're - ;; doing here, defining them as external symbols - ;; in a package which is used by both "SB-C" and - ;; "SB-IMPL". (SBCL's "SB-C" is directly - ;; analogous to CMU CL's "C"; and for this - ;; purpose, SBCL's "SB-IMPL" is analogous to CMU - ;; CL's "CL".) As far as I know there's nothing - ;; special about them, so they could be merged - ;; into the same order as everything else in the - ;; in this package. -- WHN 19990911 - "STRING>=*" "STRING>*" "STRING=*" "STRING<=*" - "STRING<*" "STRING/=*" "%SVSET" - "%SP-STRING-COMPARE" "%SETNTH" "%SETELT" - "%SET-ROW-MAJOR-AREF" "%SET-FILL-POINTER" - "%SET-FDEFINITION" "%SCHARSET" - "%RPLACD" "%RPLACA" "%PUT" "%CHARSET" - "%WITH-OUTPUT-TO-STRING")) - - #s(sb-cold:package-data - :name "SB-THREAD" - :use ("CL" "SB-ALIEN" "SB-INT" "SB-SYS" "SB-KERNEL") - :doc "public (but low-level): native thread support" - :export ("*CURRENT-THREAD*" - "DESTROY-THREAD" - "INTERRUPT-THREAD" - "INTERRUPT-THREAD-ERROR" - "INTERRUPT-THREAD-ERROR-THREAD" - "RETURN-FROM-THREAD" - "ABORT-THREAD" - "MAIN-THREAD-P" - "MAIN-THREAD" - "JOIN-THREAD" - "JOIN-THREAD-ERROR" - "JOIN-THREAD-ERROR-THREAD" - "LIST-ALL-THREADS" - "MAKE-THREAD" - "SYMBOL-VALUE-IN-THREAD" - "SYMBOL-VALUE-IN-THREAD-ERROR" - "TERMINATE-THREAD" - "THREAD" - "THREAD-DEADLOCK" - "THREAD-DEADLOCK-CYCLE" - "THREAD-ERROR" - "THREAD-ERROR-THREAD" - "THREAD-ALIVE-P" - "THREAD-EPHEMERAL-P" - "THREAD-NAME" - "THREAD-OS-TID" - "THREAD-YIELD" - "FOREIGN-THREAD" - #+(and sb-safepoint-strictly (not win32)) - "SIGNAL-HANDLING-THREAD" - ;; Memory barrier - "BARRIER" - ;; Mutexes - "GET-MUTEX" - "GRAB-MUTEX" - "HOLDING-MUTEX-P" - "MAKE-MUTEX" - "MUTEX" - "MUTEX-NAME" - "MUTEX-OWNER" - "MUTEX-VALUE" - "RELEASE-MUTEX" - "WITH-MUTEX" - "WITH-RECURSIVE-LOCK" - ;; Condition variables - "CONDITION-BROADCAST" - "CONDITION-NOTIFY" - "CONDITION-WAIT" - "MAKE-WAITQUEUE" - "WAITQUEUE" - "WAITQUEUE-NAME" - ;; Sessions - "MAKE-LISTENER-THREAD" - "RELEASE-FOREGROUND" - "WITH-NEW-SESSION" - ;; Semaphores - "MAKE-SEMAPHORE" - "SEMAPHORE" - "SEMAPHORE-NAME" - "SEMAPHORE-COUNT" - "SIGNAL-SEMAPHORE" - "TRY-SEMAPHORE" - "WAIT-ON-SEMAPHORE" - ;; Semaphore notification objects - "CLEAR-SEMAPHORE-NOTIFICATION" - "MAKE-SEMAPHORE-NOTIFICATION" - "SEMAPHORE-NOTIFICATION" - "SEMAPHORE-NOTIFICATION-STATUS")) - - #s(sb-cold:package-data - :name "SB-LOOP" - :doc "private: implementation details of LOOP" - :use ("CL" "SB-INT" "SB-KERNEL") - :export ()) - - #s(sb-cold:package-data - :name "SB-MOP" - :doc - "public: the MetaObject Protocol interface, as defined by -The Art of the Metaobject Protocol, by Kiczales, des Rivieres and Bobrow: -ISBN 0-262-61074-4, with exceptions as noted in the User Manual." - :use ("CL") - :reexport ("ADD-METHOD" - "ALLOCATE-INSTANCE" - "CLASS-NAME" "COMPUTE-APPLICABLE-METHODS" - "ENSURE-GENERIC-FUNCTION" "MAKE-INSTANCE" - "METHOD-QUALIFIERS" "REMOVE-METHOD" - "BUILT-IN-CLASS" "CLASS" - "FUNCTION" "GENERIC-FUNCTION" - "METHOD" "METHOD-COMBINATION" - "STANDARD-CLASS" "STANDARD-GENERIC-FUNCTION" - "STANDARD-METHOD" "STANDARD-OBJECT" "T") - :export ("ADD-DEPENDENT" - "ADD-DIRECT-METHOD" - "ADD-DIRECT-SUBCLASS" - "CLASS-DEFAULT-INITARGS" - "CLASS-DIRECT-DEFAULT-INITARGS" - "CLASS-DIRECT-SLOTS" - "CLASS-DIRECT-SUBCLASSES" - "CLASS-DIRECT-SUPERCLASSES" - "CLASS-FINALIZED-P" - "CLASS-PRECEDENCE-LIST" - "CLASS-PROTOTYPE" - "CLASS-SLOTS" - "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" - "COMPUTE-CLASS-PRECEDENCE-LIST" - "COMPUTE-DEFAULT-INITARGS" - "COMPUTE-DISCRIMINATING-FUNCTION" - "COMPUTE-EFFECTIVE-METHOD" - "COMPUTE-EFFECTIVE-SLOT-DEFINITION" - "COMPUTE-SLOTS" - "DIRECT-SLOT-DEFINITION" - "DIRECT-SLOT-DEFINITION-CLASS" - "EFFECTIVE-SLOT-DEFINITION" - "EFFECTIVE-SLOT-DEFINITION-CLASS" - "ENSURE-CLASS" - "ENSURE-CLASS-USING-CLASS" - "ENSURE-GENERIC-FUNCTION-USING-CLASS" - "EQL-SPECIALIZER" - "EQL-SPECIALIZER-OBJECT" - "EXTRACT-LAMBDA-LIST" - "EXTRACT-SPECIALIZER-NAMES" - "FINALIZE-INHERITANCE" - "FIND-METHOD-COMBINATION" - "FORWARD-REFERENCED-CLASS" - "FUNCALLABLE-STANDARD-CLASS" - "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" - "FUNCALLABLE-STANDARD-OBJECT" - "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" - "GENERIC-FUNCTION-DECLARATIONS" - "GENERIC-FUNCTION-LAMBDA-LIST" - "GENERIC-FUNCTION-METHOD-CLASS" - "GENERIC-FUNCTION-METHOD-COMBINATION" - "GENERIC-FUNCTION-METHODS" - "GENERIC-FUNCTION-NAME" - "INTERN-EQL-SPECIALIZER" - "MAKE-METHOD-LAMBDA" - "MAP-DEPENDENTS" - "METAOBJECT" - "METHOD-FUNCTION" - "METHOD-GENERIC-FUNCTION" - "METHOD-LAMBDA-LIST" - "METHOD-SPECIALIZERS" - "ACCESSOR-METHOD-SLOT-DEFINITION" - "READER-METHOD-CLASS" - "REMOVE-DEPENDENT" - "REMOVE-DIRECT-METHOD" - "REMOVE-DIRECT-SUBCLASS" - "SET-FUNCALLABLE-INSTANCE-FUNCTION" - "SLOT-BOUNDP-USING-CLASS" - "SLOT-DEFINITION" - "SLOT-DEFINITION-ALLOCATION" - "SLOT-DEFINITION-INITARGS" - "SLOT-DEFINITION-INITFORM" - "SLOT-DEFINITION-INITFUNCTION" - "SLOT-DEFINITION-LOCATION" - "SLOT-DEFINITION-NAME" - "SLOT-DEFINITION-READERS" - "SLOT-DEFINITION-WRITERS" - "SLOT-DEFINITION-TYPE" - "SLOT-MAKUNBOUND-USING-CLASS" - "SLOT-VALUE-USING-CLASS" - "SPECIALIZER" - "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" - "SPECIALIZER-DIRECT-METHODS" - "STANDARD-ACCESSOR-METHOD" - "STANDARD-DIRECT-SLOT-DEFINITION" - "STANDARD-EFFECTIVE-SLOT-DEFINITION" - "STANDARD-INSTANCE-ACCESS" - "STANDARD-READER-METHOD" - "STANDARD-SLOT-DEFINITION" - "STANDARD-WRITER-METHOD" - "UPDATE-DEPENDENT" - "VALIDATE-SUPERCLASS" - "WRITER-METHOD-CLASS")) - - #s(sb-cold:package-data - :name "SB-REGALLOC" - :doc "private: implementation of the compiler's register allocator" - :use ("CL" "SB-ALIEN-INTERNALS" "SB-ALIEN" "SB-ASSEM" "SB-BIGNUM" - #+sb-dyncount "SB-DYNCOUNT" "SB-EXT" "SB-FASL" "SB-INT" - "SB-KERNEL" "SB-SYS" - "SB-C") - :import-from (("SB-C" - "*LOOP-ANALYZE*" - "BLOCK-INFO" "BLOCK-LAST" "BLOCK-LOOP" "BLOCK-NEXT" - "CLEAR-BIT-VECTOR" "COMPONENT-HEAD" "COMPONENT-TAIL" - "DEFEVENT" "DELETE-VOP" "DO-IR2-BLOCKS" "DO-LIVE-TNS" - "EMIT-LOAD-TEMPLATE" "EVENT" "FIND-IN" - "FINITE-SB" "FINITE-SB-ALWAYS-LIVE" - "FINITE-SB-WIRED-MAP" "FINITE-SB-CONFLICTS" - "FINITE-SB-CURRENT-SIZE" "FINITE-SB-LAST-BLOCK-COUNT" - "FINITE-SB-LAST-OFFSET" "FINITE-SB-LIVE-TNS" - "FINITE-SB-SIZE-ALIGNMENT" "FINITE-SB-SIZE-INCREMENT" - "GET-OPERAND-INFO" "GLOBAL-CONFLICTS-BLOCK" - "GLOBAL-CONFLICTS-CONFLICTS" "GLOBAL-CONFLICTS-KIND" - "GLOBAL-CONFLICTS-NEXT-TNWISE" "GLOBAL-CONFLICTS-NUMBER" - "GLOBAL-CONFLICTS-NEXT-BLOCKWISE" "GLOBAL-CONFLICTS-TN" - "IR2-BLOCK" "IR2-BLOCK-COUNT" "IR2-BLOCK-GLOBAL-TNS" - "IR2-BLOCK-LAST-VOP" "IR2-BLOCK-LIVE-IN" - "IR2-BLOCK-LOCAL-TN-COUNT" "IR2-BLOCK-LOCAL-TNS" - "IR2-BLOCK-NEXT" "IR2-BLOCK-NUMBER" "IR2-BLOCK-PREV" - "IR2-BLOCK-START-VOP" "IR2-COMPONENT" - "IR2-COMPONENT-GLOBAL-TN-COUNTER" - "IR2-COMPONENT-NORMAL-TNS" "IR2-COMPONENT-RESTRICTED-TNS" - "IR2-COMPONENT-SPILLED-TNS" "IR2-COMPONENT-SPILLED-VOPS" - "IR2-COMPONENT-WIRED-TNS" - "LAMBDA-PARENT" "LEXENV-LAMBDA" "LISTIFY-RESTRICTIONS" - "LOCAL-TN-BIT-VECTOR" "LOCAL-TN-COUNT" "LOCAL-TN-LIMIT" - "LOCAL-TN-NUMBER" "LOCAL-TN-VECTOR" - "LOOP-DEPTH" "MAKE-TN" "MOVE-OPERAND" "NODE" "NODE-LEXENV" - "OPERAND-PARSE-NAME" "POSITION-IN" - "PRIMITIVE-TYPE-SCS" "PRINT-TN-GUTS" - "SB-KIND" "SB-SIZE" - "SC-LOCATIONS" "MAKE-SC-LOCATIONS" "SC-OFFSET-TO-SC-LOCATIONS" - "SC-LOCATIONS-COUNT" "SC-LOCATIONS-FIRST" "SC-LOCATIONS-MEMBER" - "DO-SC-LOCATIONS" - "SC-ALIGNMENT" "SC-ALLOWED-BY-PRIMITIVE-TYPE" - "SC-ALTERNATE-SCS" "SC-CONSTANT-SCS" "SC-ELEMENT-SIZE" - "SC-LOCATIONS" "SC-MOVE-FUNS" "SC-RESERVE-LOCATIONS" - "SC-SAVE-P" "SC-VECTOR" - "SET-BIT-VECTOR" - "TEMPLATE-NAME" - "TN" "TN-COST" "TN-GLOBAL-CONFLICTS" "TN-KIND" "TN-LEAF" - "TN-LOCAL" "TN-LOCAL-CONFLICTS" "TN-LOCAL-NUMBER" - "TN-NEXT" "TN-NUMBER" "TN-PRIMITIVE-TYPE" - "TN-READS" "TN-SAVE-TN" "TN-VERTEX" "TN-WRITES" - "TNS-CONFLICT" "TNS-CONFLICT-GLOBAL-GLOBAL" - "TNS-CONFLICT-LOCAL-GLOBAL" - "VOP" "VOP-ARGS" "VOP-INFO" "VOP-INFO-ARG-LOAD-SCS" - "VOP-INFO-MOVE-ARGS" "VOP-NAME" - "VOP-INFO-RESULT-LOAD-SCS" "VOP-INFO-SAVE-P" - "VOP-NODE" - "VOP-PARSE-OR-LOSE" "VOP-PARSE-TEMPS" "VOP-PREV" - "VOP-REFS" "VOP-RESULTS" "VOP-SAVE-SET" "VOP-TEMPS")) - :export ("PACK" "TARGET-IF-DESIRABLE" "*REGISTER-ALLOCATION-METHOD*" - "*PACK-ITERATIONS*" - "*PACK-ASSIGN-COSTS*" "*PACK-OPTIMIZE-SAVES*" - "*TN-WRITE-COST*" "*TN-LOOP-DEPTH-MULTIPLIER*")) - - #s(sb-cold:package-data - :name "SB-PCL" - :doc - "semi-public: This package includes useful meta-object protocol -extensions, but even they are not guaranteed to be present in later -versions of SBCL, and the other stuff in here is definitely not -guaranteed to be present in later versions of SBCL. Use of this -package is deprecated in favour of SB-MOP." - :use ("CL" "SB-MOP" "SB-INT" "SB-EXT" "SB-WALKER" "SB-KERNEL") - ;; experimental SBCL-only (for now) symbols - :export ("SYSTEM-CLASS" - - "MAKE-METHOD-LAMBDA-USING-SPECIALIZERS" - "MAKE-METHOD-SPECIALIZERS-FORM" - - "SPECIALIZER-TYPE-SPECIFIER" - "MAKE-SPECIALIZER-FORM-USING-CLASS" - "PARSE-SPECIALIZER-USING-CLASS" - "UNPARSE-SPECIALIZER-USING-CLASS" - - "+SLOT-UNBOUND+" - - "ENSURE-CLASS-FINALIZED" - - "ILLEGAL-CLASS-NAME-ERROR" - "CLASS-NOT-FOUND-ERROR" - "SPECIALIZER-NAME-SYNTAX-ERROR")) - - #s(sb-cold:package-data - :name "SB-PRETTY" - :doc "private: implementation of pretty-printing" - :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") - :export ("OUTPUT-PRETTY-OBJECT" - "PRETTY-STREAM" "PRETTY-STREAM-P" - "PPRINT-DISPATCH-TABLE" - "*PPRINT-QUOTE-WITH-SYNTACTIC-SUGAR*" - "!PPRINT-COLD-INIT")) - - #s(sb-cold:package-data - :name "SB-PROFILE" - :doc "public: the interface to the profiler" - :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") - :export ("PROFILE" "REPORT" "RESET" "UNPROFILE")) - - #s(sb-cold:package-data - :name "SB-SEQUENCE" - :doc "semi-public: implements something which might eventually -be submitted as a CDR" - :use () - :export ("PROTOCOL-UNIMPLEMENTED" - "PROTOCOL-UNIMPLEMENTED-OPERATION" - - "DOSEQUENCE" - - "MAKE-SEQUENCE-ITERATOR" "MAKE-SIMPLE-SEQUENCE-ITERATOR" - - "ITERATOR-STEP" "ITERATOR-ENDP" "ITERATOR-ELEMENT" - "ITERATOR-INDEX" "ITERATOR-COPY" - - "WITH-SEQUENCE-ITERATOR" "WITH-SEQUENCE-ITERATOR-FUNCTIONS" - - "CANONIZE-TEST" "CANONIZE-KEY" - - "EMPTYP" "LENGTH" "ELT" - "MAKE-SEQUENCE-LIKE" "ADJUST-SEQUENCE" - - "MAP" - "COUNT" "COUNT-IF" "COUNT-IF-NOT" - "FIND" "FIND-IF" "FIND-IF-NOT" - "POSITION" "POSITION-IF" "POSITION-IF-NOT" - "SUBSEQ" "COPY-SEQ" "FILL" - "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" - "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" - "REPLACE" "REVERSE" "NREVERSE" "CONCATENATE" "REDUCE" - "MISMATCH" "SEARCH" - "DELETE" "DELETE-IF" "DELETE-IF-NOT" - "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT" - "DELETE-DUPLICATES" "REMOVE-DUPLICATES" - - "SORT" "STABLE-SORT" "MERGE")) - - #s(sb-cold:package-data - :name "SB-SYS" - :doc - "private: In theory, this \"contains functions and information -necessary for system interfacing\" (said cmu-user.tex at the time -of the SBCL code fork). That probably was and is a good idea, but in -practice, the distinctions between this package and SB-KERNEL -and even SB-VM seem to have become somewhat blurred over the years. -Some anomalies (e.g. FIND-IF-IN-CLOSURE being in SB-SYS instead of -SB-KERNEL) have been undone, but probably more remain." - :use ("CL" "SB-EXT" "SB-INT") - :export (;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS - ;; is for OS-dependent stuff. %PRIMITIVE should probably be in - ;; SB-KERNEL.) - "%PRIMITIVE" - "%STANDARD-CHAR-P" - "*EXIT-ERROR-HANDLER*" - "*EXIT-IN-PROGRESS*" - "*ALLOW-WITH-INTERRUPTS*" - "*INTERRUPTS-ENABLED*" - "*INTERRUPT-PENDING*" - #+sb-thruption "*THRUPTION-PENDING*" - "*LINKAGE-INFO*" - "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*" - "*MACHINE-VERSION*" - "*PERIODIC-POLLING-FUNCTION*" - "*PERIODIC-POLLING-PERIOD*" - "*RUNTIME-DLHANDLE*" - "*SHARED-OBJECTS*" - "*STDERR*" "*STDIN*" - "*STDOUT*" - "*TTY*" - "ADD-FD-HANDLER" - "ALLOCATE-SYSTEM-MEMORY" - "ALLOW-WITH-INTERRUPTS" - "BEEP" - "BREAKPOINT-ERROR" - "CANCEL-DEADLINE" - "CLOSE-SHARED-OBJECTS" - "DEADLINE-TIMEOUT" - "DEALLOCATE-SYSTEM-MEMORY" - "DECODE-TIMEOUT" - "DECODE-INTERNAL-TIME" - "DEFER-DEADLINE" - "DYNAMIC-FOREIGN-SYMBOLS-P" - "DLOPEN-OR-LOSE" - "ENABLE-INTERRUPT" - "ENSURE-DYNAMIC-FOREIGN-SYMBOL-ADDRESS" - "EXTERN-ALIEN-NAME" - "EXIT-CODE" - "FD-STREAM" "FD-STREAM-FD" "FD-STREAM-P" - "FIND-DYNAMIC-FOREIGN-SYMBOL-ADDRESS" - "FIND-FOREIGN-SYMBOL-ADDRESS" - "FIND-FOREIGN-SYMBOL-IN-TABLE" - "FOREIGN-SYMBOL-SAP" - "FOREIGN-SYMBOL-ADDRESS" - "FOREIGN-SYMBOL-DATAREF-SAP" - "GET-MACHINE-VERSION" "GET-SYSTEM-INFO" - "IN-INTERRUPTION" - "INTERACTIVE-INTERRUPT" - "INT-SAP" - "INVALIDATE-DESCRIPTOR" - "INVOKE-INTERRUPTION" - "IO-TIMEOUT" - "LIST-DYNAMIC-FOREIGN-SYMBOLS" - "MACRO" "MAKE-FD-STREAM" - "MEMORY-FAULT-ERROR" - "MEMMOVE" - "NLX-PROTECT" - "OS-EXIT" - "OS-COLD-INIT-OR-REINIT" "OS-DEINIT" - "OS-CONTEXT-T" "OUTPUT-RAW-BYTES" - "READ-CYCLE-COUNTER" "ELAPSED-CYCLES" - "READ-N-BYTES" - "REMOVE-FD-HANDLER" - "REOPEN-SHARED-OBJECTS" - "SAP+" "SAP-" - "SAP-FOREIGN-SYMBOL" - "SAP-INT" - "SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-WORD" - "SAP-REF-8" - "SAP-REF-DOUBLE" "SAP-REF-LISPOBJ" "SAP-REF-LONG" - "SAP-REF-SAP" "SAP-REF-SINGLE" - "SAP<" "SAP<=" "SAP=" "SAP>" "SAP>=" - "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS" - "SIGNAL-DEADLINE" - "SERVE-EVENT" - "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32" - "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-WORD" "SIGNED-SAP-REF-8" - "STRUCTURE!OBJECT" - "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" - "SYSTEM-CONDITION" "SYSTEM-CONDITION-ADDRESS" - "SYSTEM-CONDITION-CONTEXT" - "REINIT-INTERNAL-REAL-TIME" - "SYSTEM-INTERNAL-RUN-TIME" - "UNDEFINED-FOREIGN-SYMBOLS-P" - "UPDATE-LINKAGE-TABLE" "VECTOR-SAP" - "WAIT-UNTIL-FD-USABLE" - "WITH-CODE-PAGES-PINNED" - "WITH-DEADLINE" - "WITH-FD-HANDLER" - "WITH-INTERRUPTS" "WITH-LOCAL-INTERRUPTS" - "WITH-PINNED-OBJECTS" "WITHOUT-GCING" - "WITHOUT-INTERRUPTS" - "WITH-INTERRUPT-BINDINGS")) - - #s(sb-cold:package-data - :name "SB-UNICODE" - :doc "public: algorithms for Unicode data" - :use ("CL" "SB-INT") - :export ("GENERAL-CATEGORY" - "BIDI-CLASS" - "COMBINING-CLASS" - "DECIMAL-VALUE" - "DIGIT-VALUE" - "NUMERIC-VALUE" - "MIRRORED-P" - "BIDI-MIRRORING-GLYPH" - "AGE" - "HANGUL-SYLLABLE-TYPE" - "EAST-ASIAN-WIDTH" - "SCRIPT" - "CHAR-BLOCK" - "UNICODE-1-NAME" - "LINE-BREAK-CLASS" - "PROPLIST-P" - "UPPERCASE-P" - "LOWERCASE-P" - "CASED-P" - "CASE-IGNORABLE-P" - "ALPHABETIC-P" - "IDEOGRAPHIC-P" - "MATH-P" - "WHITESPACE-P" - "HEX-DIGIT-P" - "SOFT-DOTTED-P" - "DEFAULT-IGNORABLE-P" - "NORMALIZE-STRING" - "NORMALIZED-P" - "UPPERCASE" - "LOWERCASE" - "TITLECASE" - "CASEFOLD" - "GRAPHEME-BREAK-CLASS" - "WORD-BREAK-CLASS" - "SENTENCE-BREAK-CLASS" - "GRAPHEMES" - "WORDS" - "SENTENCES" - "LINES" - "UNICODE=" - "UNICODE-EQUAL" - "UNICODE<" - "UNICODE<=" - "UNICODE>" - "UNICODE>=" - "CONFUSABLE-P")) - - #s(sb-cold:package-data - :name "SB-UNIX" - :doc - "private: a wrapper layer for SBCL itself to use when talking -with an underlying Unix-y operating system. -This was a public package in CMU CL, but that was different. -CMU CL's UNIX package tried to provide a comprehensive, -stable Unix interface suitable for the end user. -This package only tries to implement what happens to be -needed by the current implementation of SBCL, and makes -no guarantees of interface stability." - :use ("CL" "SB-ALIEN" "SB-EXT" "SB-INT" "SB-SYS") - :reexport ("OFF-T" - "SIZE-T") - :export ( ;; wrappers around Unix stuff to give just what Lisp needs - "NANOSLEEP" - "UID-USERNAME" - "UID-HOMEDIR" - "USER-HOMEDIR" - "SB-MKSTEMP" - "UNIX-OFFSET" - "FD-TYPE" - - ;; Most of this is random detritus worthy of deletion, - ;; and the ordering is not alphabetical or anything sane. - - ;; stuff with a one-to-one mapping to Unix constructs - "DEV-T" - "F_OK" "GID-T" - "INO-T" "UNIX-ACCESS" "UNIX-SETITIMER" "UNIX-GETITIMER" - "L_INCR" "L_SET" "L_XTND" "O_APPEND" "O_CREAT" "O_NOCTTY" "O_EXCL" - "O_RDONLY" "O_RDWR" "O_TRUNC" "O_WRONLY" "POSIX-GETCWD" - "POSIX-GETCWD/" - "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS" - "RU-MAJFLT" "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND" - "RU-NIVCSW" "RU-NSIGNALS" "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK" - "RU-STIME" "RU-UTIME" "RUSAGE_CHILDREN" "RUSAGE_SELF" - "R_OK" "S-IFDIR" "S-IFLNK" "S-IFMT" - "S-IFREG" - "ST-ATIME" "ST-BLKSIZE" "ST-BLOCKS" - "ST-CTIME" "ST-DEV" "ST-GID" "ST-MODE" "ST-MTIME" "ST-NLINK" - "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "TIME-T" - "TIMEVAL" "TIMEZONE" - "TIOCGPGRP" - "TV-SEC" "TV-USEC" - "TZ-DSTTIME" "TZ-MINUTESWEST" "UID-T" "UNIX-CLOSE" - "UNIX-CLOSEDIR" "UNIX-DIRENT-NAME" "UNIX-DUP" - "UNIX-FILE-MODE" "UNIX-FSTAT" - "UNIX-GETHOSTNAME" "UNIX-GETPID" "UNIX-GETRUSAGE" - "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID" - "UNIX-EXIT" - "UNIX-IOCTL" - "UNIX-ISATTY" "UNIX-LSEEK" "UNIX-LSTAT" "UNIX-MKDIR" - "UNIX-OPEN" "UNIX-OPENDIR" "UNIX-PATHNAME" "UNIX-PID" - "UNIX-PIPE" "UNIX-POLL" "UNIX-SIMPLE-POLL" - "UNIX-READ" "UNIX-READDIR" "UNIX-READLINK" "UNIX-REALPATH" - "UNIX-RENAME" "UNIX-SELECT" "UNIX-STAT" "UNIX-UID" - "UNIX-UNLINK" "UNIX-WRITE" - "WCONTINUED" "WNOHANG" "WUNTRACED" - "W_OK" "X_OK" - "SC-NPROCESSORS-ONLN" - "VOID-SYSCALL" - - ;; signals - "SIGALRM" "SIGBUS" "SIGCHLD" "SIGCONT" "SIGEMT" "SIGFPE" - "SIGHUP" "SIGILL" "SIGINT" "SIGIO" "SIGKILL" - "SIGPIPE" "SIGPROF" "SIGQUIT" "SIGSEGV" "SIGSTOP" "SIGSYS" - "SIGTERM" "SIGTRAP" "SIGTSTP" "SIGTTIN" "SIGTTOU" "SIGURG" - "SIGUSR1" "SIGUSR2" "SIGVTALRM" "SIGWINCH" - "SIGXCPU" "SIGXFSZ" - - ;; errors - "EAGAIN" "EBADF" "EEXIST" "EINTR" "EIO" "ELOOP" "ENOENT" - "EPIPE" "ESPIPE" "EWOULDBLOCK" - - "POLLFD" "POLLIN" "POLLOUT" "POLLHUP" "POLLNVAL" "POLLERR" - "FD" "EVENTS" "REVENTS" - "FD-ISSET" "FD-SET" "UNIX-FAST-SELECT" - "UNIX-KILL" - "FD-ZERO" "FD-CLR" - "FD-SETSIZE" - "UNIX-KILLPG")) - - #s(sb-cold:package-data - :name "SB-VM" - :doc - "internal: the default place to hide information about the hardware and data -structure representations" - :use ("CL" "SB-ALIEN" "SB-ALIEN-INTERNALS" "SB-ASSEM" "SB-C" - "SB-EXT" "SB-FASL" "SB-INT" "SB-KERNEL" "SB-SYS" "SB-UNIX") - :reexport ("WORD") - :export ("*ALLOC-SIGNAL*" - "*PRIMITIVE-OBJECTS*" - "+HIGHEST-NORMAL-GENERATION+" - "+PSEUDO-STATIC-GENERATION+" - "+ARRAY-FILL-POINTER-P+" - "+VECTOR-SHAREABLE+" - "+VECTOR-SHAREABLE-NONSTD+" - "%COMPILER-BARRIER" "%DATA-DEPENDENCY-BARRIER" - "%MEMORY-BARRIER" "%READ-BARRIER" "%WRITE-BARRIER" - "AFTER-BREAKPOINT-TRAP" - #+(and gencgc sparc) "ALLOCATION-TRAP" - "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" - "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT" - "ARRAY-DISPLACED-FROM-SLOT" - "ARRAY-ELEMENTS-SLOT" "ARRAY-FILL-POINTER-P-SLOT" - "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" - "CHARACTER-REG-SC-NUMBER" - "CHARACTER-STACK-SC-NUMBER" "CHARACTER-WIDETAG" - "BIGNUM-DIGITS-OFFSET" "BIGNUM-WIDETAG" "BINDING-SIZE" - "BINDING-SYMBOL-SLOT" "BINDING-VALUE-SLOT" "BREAKPOINT-TRAP" - "N-BYTE-BITS" "BYTE-REG-SC-NUMBER" - "CATCH-BLOCK-CODE-SLOT" - "CATCH-BLOCK-CFP-SLOT" "CATCH-BLOCK-UWP-SLOT" - "CATCH-BLOCK-ENTRY-PC-SLOT" "CATCH-BLOCK-PREVIOUS-CATCH-SLOT" - "CATCH-BLOCK-SC-NUMBER" "CATCH-BLOCK-SIZE" - "CATCH-BLOCK-TAG-SLOT" "CERROR-TRAP" - "CLOSURE-FUN-SLOT" - "CLOSURE-WIDETAG" - "CLOSURE-INFO-OFFSET" - "CODE-BOXED-SIZE-SLOT" - "CODE-CONSTANTS-OFFSET" "CODE-SLOTS-PER-SIMPLE-FUN" - "CODE-DEBUG-INFO-SLOT" - "CODE-HEADER-SIZE-SHIFT" - "CODE-HEADER-WIDETAG" "COMPLEX-ARRAY-WIDETAG" - "COMPLEX-BIT-VECTOR-WIDETAG" "COMPLEX-DOUBLE-FLOAT-FILLER-SLOT" - "COMPLEX-DOUBLE-FLOAT-IMAG-SLOT" "COMPLEX-DOUBLE-FLOAT-REAL-SLOT" - "COMPLEX-DOUBLE-FLOAT-SIZE" "COMPLEX-DOUBLE-FLOAT-WIDETAG" - "COMPLEX-DOUBLE-REG-SC-NUMBER" "COMPLEX-DOUBLE-STACK-SC-NUMBER" - "COMPLEX-IMAG-SLOT" "COMPLEX-REAL-SLOT" - #+long-float("COMPLEX-LONG-FLOAT-IMAG-SLOT" - "COMPLEX-LONG-FLOAT-REAL-SLOT" - "COMPLEX-LONG-FLOAT-SIZE" - "COMPLEX-LONG-FLOAT-WIDETAG" - "COMPLEX-LONG-REG-SC-NUMBER" - "COMPLEX-LONG-STACK-SC-NUMBER") - #+sb-simd-pack("SIMD-PACK-TAG-SLOT" - "SIMD-PACK-HI-VALUE-SLOT" - "SIMD-PACK-LO-VALUE-SLOT" - "SIMD-PACK-SIZE" - "SIMD-PACK-WIDETAG") - #+sb-simd-pack-256("SIMD-PACK-256-TAG-SLOT" - "SIMD-PACK-256-P0-SLOT" - "SIMD-PACK-256-P1-SLOT" - "SIMD-PACK-256-P2-SLOT" - "SIMD-PACK-256-P3-SLOT" - "SIMD-PACK-256-SIZE" - "SIMD-PACK-256-WIDETAG") - #-64-bit - ("COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT") - #+64-bit - "COMPLEX-SINGLE-FLOAT-DATA-SLOT" - "COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-WIDETAG" - "COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER" - "COMPLEX-SIZE" "COMPLEX-BASE-STRING-WIDETAG" - #+sb-unicode "COMPLEX-CHARACTER-STRING-WIDETAG" - "COMPLEX-WIDETAG" - "COMPLEX-VECTOR-NIL-WIDETAG" - "COMPLEX-VECTOR-WIDETAG" "CONS-CAR-SLOT" "CONS-CDR-SLOT" - "CONS-SIZE" "CONSTANT-SC-NUMBER" - "CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER" - "CONTEXT-PC" "CONTEXT-REGISTER" "BOXED-CONTEXT-REGISTER" - "CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS" - #+sb-safepoint "CSP-SAFEPOINT-TRAP" - "*CURRENT-CATCH-BLOCK*" - "CURRENT-FLOAT-TRAP" - "DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE" - "DO-REFERENCED-OBJECT" - "DOUBLE-FLOAT-BIAS" - "DOUBLE-FLOAT-DIGITS" "DOUBLE-FLOAT-EXPONENT-BYTE" - "DOUBLE-FLOAT-HIDDEN-BIT" - "DOUBLE-FLOAT-NORMAL-EXPONENT-MAX" - "DOUBLE-FLOAT-NORMAL-EXPONENT-MIN" "DOUBLE-FLOAT-SIGNIFICAND-BYTE" - "DOUBLE-FLOAT-SIZE" "DOUBLE-FLOAT-TRAPPING-NAN-BIT" - "DOUBLE-FLOAT-WIDETAG" "DOUBLE-FLOAT-VALUE-SLOT" - "DOUBLE-REG-SC-NUMBER" - "DOUBLE-STACK-SC-NUMBER" - "DSD-INDEX-SHIFT" - "DSD-RAW-TYPE-MASK" - "EMIT-LONG-NOP" "ERROR-TRAP" "EVEN-FIXNUM-LOWTAG" - "FDEFN-FUN-SLOT" "FDEFN-NAME-SLOT" "FDEFN-RAW-ADDR-SLOT" - "FDEFN-SIZE" "FDEFN-WIDETAG" - "FILLER-WIDETAG" - "FIXNUMIZE" - "FIXNUM-TAG-MASK" - "FIXUP-CODE-OBJECT" "FLOAT-DENORMAL-TRAP-BIT" - "FLOAT-DIVIDE-BY-ZERO-TRAP-BIT" - "FLOAT-INVALID-TRAP-BIT" - "FLOAT-OVERFLOW-TRAP-BIT" "FLOAT-SIGN-SHIFT" - "FLOAT-UNDERFLOW-TRAP-BIT" "FLOATING-POINT-MODES" - "FLOAT-STICKY-BITS" - "FLOAT-TRAPS-BYTE" - "FP-CONSTANT-SC-NUMBER" - "FP-DOUBLE-ZERO-SC-NUMBER" "FP-SINGLE-ZERO-SC-NUMBER" - "FUNCALLABLE-INSTANCE-TRAMPOLINE-SLOT" - "FUNCALLABLE-INSTANCE-WIDETAG" - "FUNCALLABLE-INSTANCE-INFO-OFFSET" - "SIMPLE-FUN-ARGLIST-SLOT" "SIMPLE-FUN-INSTS-OFFSET" - "FUN-END-BREAKPOINT-TRAP" - "SIMPLE-FUN-WIDETAG" - "SIMPLE-FUN-NAME-SLOT" - "SIMPLE-FUN-ENTRY-SAP" - "FUN-POINTER-LOWTAG" - "FUNCTION-LAYOUT" - "SIMPLE-FUN-INFO-SLOT" - "SIMPLE-FUN-SELF-SLOT" - "SIMPLE-FUN-SOURCE-SLOT" - "GENCGC-CARD-BYTES" - "GENCGC-ALLOC-GRANULARITY" - "GENCGC-RELEASE-GRANULARITY" - #+(or arm64 ppc ppc64 sparc riscv) "PSEUDO-ATOMIC-INTERRUPTED-FLAG" - #+(or arm64 ppc ppc64 sparc riscv) "PSEUDO-ATOMIC-FLAG" - #+sb-safepoint "GLOBAL-SAFEPOINT-TRAP" - "HALT-TRAP" "IGNORE-ME-SC-NUMBER" - "IMMEDIATE-SC-NUMBER" - ("CANONICALIZE-INLINE-CONSTANT" - "INLINE-CONSTANT-VALUE" - "SORT-INLINE-CONSTANTS" - "EMIT-INLINE-CONSTANT") - "HEXDUMP" - "INSTANCE-DATA-START" - "INSTANCE-WIDETAG" "INSTANCE-POINTER-LOWTAG" - "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE" - "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGS" - "INTERRUPTED-FLAG" - "IS-LISP-POINTER" - #+gencgc "LARGE-OBJECT-SIZE" - "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-LOWTAG" - ;; FIXME: Possibly these other parameters (see - ;; compiler/{x86,sparc}/parms.lisp) should be defined - ;; conditionally on #+LONG-FLOAT) - "LONG-FLOAT-BIAS" "LONG-FLOAT-DIGITS" "LONG-FLOAT-EXPONENT-BYTE" - "LONG-FLOAT-HIDDEN-BIT" "LONG-FLOAT-NORMAL-EXPONENT-MAX" - "LONG-FLOAT-NORMAL-EXPONENT-MIN" "LONG-FLOAT-SIGNIFICAND-BYTE" - #+long-float "LONG-FLOAT-SIZE" - "LONG-FLOAT-TRAPPING-NAN-BIT" - #+long-float("LONG-FLOAT-WIDETAG" - "LONG-FLOAT-VALUE-SLOT" - "LONG-REG-SC-NUMBER" - "LONG-STACK-SC-NUMBER") - "LOWTAG-LIMIT" "LOWTAG-MASK" - "LRA-SAVE-OFFSET" - "MAP-ALLOCATED-OBJECTS" - "MAX-INTERRUPTS" - #+c-stack-is-control-stack "MEMORY-FAULT-EMULATION-TRAP" - "UNINITIALIZED-LOAD-TRAP" - "MEMORY-USAGE" - "N-LOWTAG-BITS" - "N-FIXNUM-TAG-BITS" - "N-FIXNUM-BITS" - "N-POSITIVE-FIXNUM-BITS" - "NIL-VALUE" - "NFP-SAVE-OFFSET" - "NON-DESCRIPTOR-REG-SC-NUMBER" - "NULL-SC-NUMBER" - "OCFP-SAVE-OFFSET" - "ODD-FIXNUM-LOWTAG" - "OTHER-IMMEDIATE-0-LOWTAG" - "OTHER-IMMEDIATE-1-LOWTAG" - "OTHER-IMMEDIATE-2-LOWTAG" - "OTHER-IMMEDIATE-3-LOWTAG" - "OTHER-POINTER-LOWTAG" - "PAD0-LOWTAG" "PAD1-LOWTAG" "PAD2-LOWTAG" - "PAD3-LOWTAG" "PAD4-LOWTAG" "PAD5-LOWTAG" - "PAD-DATA-BLOCK" "PENDING-INTERRUPT-TRAP" - "PRIMITIVE-OBJECT" "PRIMITIVE-OBJECT-WIDETAG" - "PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME" - "PRIMITIVE-OBJECT-OPTIONS" "PRIMITIVE-OBJECT-P" - "PRIMITIVE-OBJECT-LENGTH" "PRIMITIVE-OBJECT-SLOTS" - "PRIMITIVE-OBJECT-VARIABLE-LENGTH-P" - "PRINT-ALLOCATED-OBJECTS" - "RATIO-DENOMINATOR-SLOT" "RATIO-NUMERATOR-SLOT" - "RATIO-SIZE" "RATIO-WIDETAG" - "*READ-ONLY-SPACE-FREE-POINTER*" - "RETURN-PC-WIDETAG" - "RETURN-PC-RETURN-POINT-OFFSET" "RETURN-PC-SAVE-OFFSET" - "SAETP-CTYPE" "SAETP-INITIAL-ELEMENT-DEFAULT" - "SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMITIVE-TYPE-NAME" - "SAETP-N-PAD-ELEMENTS" "SAETP-N-BITS-SHIFT" - "SAETP-SPECIFIER" - "SAETP-COMPLEX-TYPECODE" "SAETP-IMPORTANCE" - "SAETP-FIXNUM-P" - "VALID-BIT-BASH-SAETP-P" - "*SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*" - "SANCTIFY-FOR-EXECUTION" - "SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE" - "SAP-STACK-SC-NUMBER" "SAP-WIDETAG" - "SC-NUMBER-LIMIT" "SC-NUMBER-BITS" ; SC-NUMBER in package "SB-C" - "SC-OFFSET-LIMIT" "SC-OFFSET-BITS" "SC-OFFSET" - "FINITE-SC-OFFSET-LIMIT" "FINITE-SC-OFFSET-BITS" "FINITE-SC-OFFSET" - "FINITE-SC-OFFSET-MAP" - "SHORT-HEADER-MAX-WORDS" - "SIGFPE-HANDLER" "SIGNED-REG-SC-NUMBER" "SIGNED-STACK-SC-NUMBER" - "SIGNED-WORD" - "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-WIDETAG" - #+long-float "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-WIDETAG" - "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-WIDETAG" - "SIMPLE-ARRAY-DOUBLE-FLOAT-WIDETAG" - #+long-float "SIMPLE-ARRAY-LONG-FLOAT-WIDETAG" - "SIMPLE-ARRAY-NIL-WIDETAG" - "SIMPLE-ARRAY-SINGLE-FLOAT-WIDETAG" - "SIMPLE-ARRAY-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-15-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-16-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-2-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-FIXNUM-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-31-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-32-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-63-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-64-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-4-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-7-WIDETAG" - "SIMPLE-ARRAY-UNSIGNED-BYTE-8-WIDETAG" - "SIMPLE-ARRAY-SIGNED-BYTE-16-WIDETAG" - "SIMPLE-ARRAY-FIXNUM-WIDETAG" - "SIMPLE-ARRAY-SIGNED-BYTE-32-WIDETAG" - "SIMPLE-ARRAY-SIGNED-BYTE-64-WIDETAG" - "SIMPLE-ARRAY-SIGNED-BYTE-8-WIDETAG" - "SIMPLE-BIT-VECTOR-WIDETAG" - "SIMPLE-BASE-STRING-WIDETAG" - #+sb-unicode "SIMPLE-CHARACTER-STRING-WIDETAG" - "SIMPLE-VECTOR-WIDETAG" "SINGLE-FLOAT-BIAS" - "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE" - "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX" - "SINGLE-FLOAT-NORMAL-EXPONENT-MIN" "SINGLE-FLOAT-SIGNIFICAND-BYTE" - "SINGLE-FLOAT-SIZE" "SINGLE-FLOAT-TRAPPING-NAN-BIT" - "SINGLE-FLOAT-WIDETAG" - #-64-bit "SINGLE-FLOAT-VALUE-SLOT" - "SINGLE-REG-SC-NUMBER" "SINGLE-STACK-SC-NUMBER" - "SINGLE-STEP-AROUND-TRAP" - "SINGLE-STEP-BEFORE-TRAP" - "SINGLE-STEP-BREAKPOINT-TRAP" - "INVALID-ARG-COUNT-TRAP" - "SINGLE-VALUE-RETURN-BYTE-OFFSET" - "SLOT-NAME" "SLOT-OFFSET" "SLOT-OPTIONS" - "SLOT-SPECIAL" - "SLOT-REST-P" "+STATIC-FDEFNS+" "STATIC-FUN-OFFSET" - "%SPACE-BOUNDS" "SPACE-BYTES" - "STABLE-HASH-REQUIRED-FLAG" - "HASH-SLOT-PRESENT-FLAG" - "STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P" - "*STATIC-SPACE-FREE-POINTER*" "+STATIC-SYMBOLS+" - "SYMBOL-HASH-SLOT" "SYMBOL-WIDETAG" "SYMBOL-NAME-SLOT" - "SYMBOL-PACKAGE-SLOT" "SYMBOL-INFO-SLOT" - "SYMBOL-SIZE" "SYMBOL-VALUE-SLOT" "SYMBOL-TLS-INDEX-SLOT" - "EXTENDED-SYMBOL-SIZE" - "*BINDING-STACK-START*" - "*CONTROL-STACK-START*" "*CONTROL-STACK-END*" - "CONTROL-STACK-POINTER-VALID-P" - "DYNAMIC-SPACE-START" "DYNAMIC-SPACE-END" - #+gencgc("MAX-DYNAMIC-SPACE-END" - "PAGE-TABLE" - "FIND-PAGE-INDEX" - "NEXT-FREE-PAGE") - #-gencgc("DYNAMIC-0-SPACE-START" - "DYNAMIC-0-SPACE-END") - #+immobile-space("IMMOBILE-CARD-BYTES" - "FIXEDOBJ-SPACE-START" "FIXEDOBJ-SPACE-SIZE" - "VARYOBJ-SPACE-START" "VARYOBJ-SPACE-SIZE" - "*FIXEDOBJ-SPACE-FREE-POINTER*" - "*VARYOBJ-SPACE-FREE-POINTER*") - "READ-ONLY-SPACE-START" "READ-ONLY-SPACE-END" - "STATIC-SPACE-START" "STATIC-SPACE-END" - ("LINKAGE-TABLE-SPACE-START" - "LINKAGE-TABLE-SPACE-END" - "LINKAGE-TABLE-ENTRY-SIZE") - #+sb-safepoint "GC-SAFEPOINT-PAGE-ADDR" - #+sb-safepoint "GC-SAFEPOINT-TRAP-OFFSET" - "TLS-SIZE" "N-WIDETAG-BITS" "WIDETAG-MASK" - "INSTANCE-LENGTH-SHIFT" - "UNBOUND-MARKER-WIDETAG" - "UNDEFINED-FUNCTION-TRAP" - "NO-TLS-VALUE-MARKER-WIDETAG" - "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER" - "UNWIND-BLOCK-CODE-SLOT" "UNWIND-BLOCK-CFP-SLOT" - "UNWIND-BLOCK-UWP-SLOT" "UNWIND-BLOCK-ENTRY-PC-SLOT" - "UNWIND-BLOCK-SIZE" "VALUE-CELL-WIDETAG" "VALUE-CELL-SIZE" - "VALUE-CELL-VALUE-SLOT" "VECTOR-DATA-OFFSET" "VECTOR-LENGTH-SLOT" - "VECTOR-WEAK-FLAG" - "VECTOR-WEAK-VISITED-FLAG" - "VECTOR-HASHING-FLAG" - "VECTOR-ADDR-HASHING-FLAG" - "WEAK-POINTER-NEXT-SLOT" - "WEAK-POINTER-SIZE" "WEAK-POINTER-WIDETAG" - "WEAK-POINTER-VALUE-SLOT" - "N-WORD-BITS" "N-WORD-BYTES" "N-MACHINE-WORD-BITS" "N-MACHINE-WORD-BYTES" - "WORD-REG-SC-NUMBER" "WORD-SHIFT" - #+win32 "CONTEXT-RESTORE-TRAP" - "ZERO-SC-NUMBER")) - - #s(sb-cold:package-data - :name "SB-RBTREE" - :doc "internal: red/black tree" - :use ("CL" "SB-INT" "SB-EXT") - :shadow ("DELETE") - :export ("INSERT" "DELETE" "FIND=" "FIND<=")) - - #s(sb-cold:package-data - :name "SB-LOCKLESS" - :doc "internal: lockfree lists" - :use ("CL" "SB-INT" "SB-EXT" "SB-SYS" "SB-KERNEL") - :shadow ("ENDP")) - - #s(sb-cold:package-data - :name "SB-WALKER" - :doc "internal: a code walker used by PCL" - :use ("CL" "SB-INT" "SB-EXT")) - - #+sb-eval - #s(sb-cold:package-data - :name "SB-EVAL" - :doc "internal: the evaluator implementation used to execute code without compiling it." - :use ("CL" "SB-KERNEL" "SB-EXT" "SB-INT") - :reexport ("*EVAL-CALLS*") - :export ("INTERPRETED-FUNCTION-NAME" - "INTERPRETED-FUNCTION-DEBUG-NAME" - "INTERPRETED-FUNCTION-LAMBDA-LIST" - "INTERPRETED-FUNCTION-DEBUG-LAMBDA-LIST" - "INTERPRETED-FUNCTION-DECLARATIONS" - "INTERPRETED-FUNCTION-DOCUMENTATION" - "INTERPRETED-FUNCTION-BODY" - "INTERPRETED-FUNCTION-SOURCE-LOCATION" - "EVAL-IN-ENVIRONMENT" - "MAKE-NULL-ENVIRONMENT" - "EVAL-IN-NATIVE-ENVIRONMENT" - "*EVAL-LEVEL*")) - - #+sb-fasteval - #s(sb-cold:package-data - :name "SB-INTERPRETER" - :doc "internal: a new EVAL implementation with semantic preprocessing." - :use ("CL" "SB-KERNEL" "SB-EXT" "SB-INT") - :export ("BASIC-ENV" - "ENV-POLICY" - "EVAL-IN-ENVIRONMENT" - "FIND-LEXICAL-FUN" - "FIND-LEXICAL-VAR" - "FUN-LAMBDA-EXPRESSION" - "FUN-LAMBDA-LIST" - "FUN-PROTO-FN" - "FUN-SOURCE-LOCATION" - "%FUN-TYPE" ; to avoid conflict with SB-KERNEL:FUN-TYPE - "LEXENV-FROM-ENV" - "LIST-LOCALS" - "PROTO-FN-DOCSTRING" - "PROTO-FN-NAME" - "PROTO-FN-PRETTY-ARGLIST" - "TYPE-CHECK") - :import-from (("SB-C" - "PARSE-EVAL-WHEN-SITUATIONS" - "MAKE-GLOBAL-VAR" "MAKE-LAMBDA-VAR" - "*LEXENV*") - ("SB-VM" "SYMBOL-EXTRA-SLOT-P" "SYMBOL-EXTRA") - ("SB-ALIEN" "%HEAP-ALIEN" "ALIEN-VALUE") - ("SB-KERNEL" "%%TYPEP"))) - - #+win32 - #s(sb-cold:package-data - :name "SB-WIN32" - :doc "private: a wrapper layer for Win32 functions needed by -SBCL itself" - :use ("CL" "SB-ALIEN" "SB-EXT" "SB-INT" "SB-SYS") - :export ("BOOL" - "CLOSE-HANDLE" - "CREATE-FILE" - "CREATE-FILE-MAPPING" - "CRYPT-GEN-RANDOM" - "DWORD" - "EXCEPTION" - "EXCEPTION-RECORD" - "EXCEPTION-CONTEXT" - "EXCEPTION-CODE" - "FILE-CREATE-ALWAYS" - "FILE-CREATE-NEW" - "FILE-OPEN-ALWAYS" - "FILE-OPEN-EXISTING" - "FILE-TRUNCATE-EXISTING" - "FLUSH-CONSOLE-INPUT-BUFFER" - "FLUSH-VIEW-OF-FILE" - "FORMAT-SYSTEM-MESSAGE" - "GET-FILE-ATTRIBUTES" - "GET-FILE-SIZE-EX" - "GET-FILE-TYPE" - "GET-LAST-ERROR" - "GET-OSFHANDLE" - "GET-VERSION-EX" - "HANDLE" - "HANDLE-CLEAR-INPUT" - "HANDLE-LISTEN" - "INT-PTR" - "INVALID-HANDLE" - "LSEEKI64" - "MAP-VIEW-OF-FILE" - "MILLISLEEP" - "PEEK-CONSOLE-INPUT" - "PEEK-NAMED-PIPE" - "READ-FILE" - "UNIXLIKE-CLOSE" - "UNIXLIKE-OPEN" - "UNMAP-VIEW-OF-FILE" - "WAIT-OBJECT-OR-SIGNAL" - "WRITE-FILE" - "WITH-PROCESS-TIMES"))) - -;;; The following symbols may be referenced without seeing a definition -;;; during make-host-2. No warning will result. -;;; This list is read after packages are created from the data above. -((;; CL, EXT, KERNEL - allocate-instance - compute-applicable-methods - slot-makunbound - make-load-form-saving-slots - sb-vm:map-allocated-objects - sb-ext:primitive-object-size - sb-vm::remove-static-links) - ;; CLOS implementation - (sb-mop:class-finalized-p - sb-mop:class-prototype - sb-mop:class-slots - sb-pcl::eql-specializer-to-ctype - sb-mop:finalize-inheritance - sb-mop:generic-function-name - (setf sb-mop:generic-function-name) - sb-mop:slot-definition-allocation - sb-mop:slot-definition-name - sb-pcl::method-p - sb-mop:method-function - sb-pcl::%force-cache-flushes - sb-pcl::check-wrapper-validity - sb-pcl::class-has-a-forward-referenced-superclass-p - sb-pcl::class-wrapper - sb-pcl::compute-gf-ftype - sb-pcl::definition-source - sb-pcl::ensure-accessor - sb-pcl:ensure-class-finalized) - ;; CLOS-based packages - (sb-gray:stream-clear-input - sb-gray:stream-clear-output - sb-gray:stream-file-position - sb-gray:stream-finish-output - sb-gray:stream-force-output - sb-gray:stream-fresh-line - sb-gray:stream-line-column - sb-gray:stream-line-length - sb-gray:stream-listen - sb-gray:stream-peek-char - sb-gray:stream-read-byte - sb-gray:stream-read-char - sb-gray:stream-read-char-no-hang - sb-gray:stream-read-line - sb-gray:stream-read-sequence - sb-gray:stream-terpri - sb-gray:stream-unread-char - sb-gray:stream-write-byte - sb-gray:stream-write-char - sb-gray:stream-write-sequence - sb-gray:stream-write-string - sb-sequence:concatenate - sb-sequence:copy-seq - sb-sequence:count - sb-sequence:count-if - sb-sequence:count-if-not - sb-sequence:delete - sb-sequence:delete-duplicates - sb-sequence:delete-if - sb-sequence:delete-if-not - (setf sb-sequence:elt) - sb-sequence:elt - sb-sequence:emptyp - sb-sequence:fill - sb-sequence:find - sb-sequence:find-if - sb-sequence:find-if-not - (setf sb-sequence:iterator-element) - sb-sequence:iterator-endp - sb-sequence:iterator-step - sb-sequence:length - sb-sequence:make-sequence-iterator - sb-sequence:make-sequence-like - sb-sequence:map - sb-sequence:merge - sb-sequence:mismatch - sb-sequence:nreverse - sb-sequence:nsubstitute - sb-sequence:nsubstitute-if - sb-sequence:nsubstitute-if-not - sb-sequence:position - sb-sequence:position-if - sb-sequence:position-if-not - sb-sequence:reduce - sb-sequence:remove - sb-sequence:remove-duplicates - sb-sequence:remove-if - sb-sequence:remove-if-not - sb-sequence:replace - sb-sequence:reverse - sb-sequence:search - sb-sequence:sort - sb-sequence:stable-sort - sb-sequence:subseq - sb-sequence:substitute - sb-sequence:substitute-if - sb-sequence:substitute-if-not) - ;; Fast interpreter - #+sb-fasteval - (sb-interpreter:%fun-type - sb-interpreter:env-policy - sb-interpreter:eval-in-environment - sb-interpreter:find-lexical-fun - sb-interpreter:find-lexical-var - sb-interpreter::flush-everything - sb-interpreter::fun-lexically-notinline-p - sb-interpreter:lexenv-from-env - sb-interpreter::lexically-unlocked-symbol-p - sb-interpreter:list-locals - sb-interpreter::reconstruct-syntactic-closure-env) - ;; Simple-streams symbols in SB-IMPL - (sb-impl::s-%charpos - sb-impl::s-%clear-output - sb-impl::s-%file-length - sb-impl::s-%file-name - sb-impl::s-%file-position - sb-impl::s-%file-string-length - sb-impl::s-%finish-output - sb-impl::s-%force-output - sb-impl::s-%fresh-line - sb-impl::s-%line-length - sb-impl::s-%peek-char - sb-impl::s-%read-byte - sb-impl::s-%read-char - sb-impl::s-%read-char-no-hang - sb-impl::s-%read-line - sb-impl::s-%stream-external-format - sb-impl::s-%terpri - sb-impl::s-%unread-char - sb-impl::s-%write-byte - sb-impl::s-%write-char - sb-impl::s-%write-line - sb-impl::s-%write-sequence - sb-impl::s-%write-string) - ;; Other - (sb-debug::find-interrupted-name-and-frame - sb-impl::encapsulate-generic-function - sb-impl::encapsulated-generic-function-p - sb-impl::get-processes-status-changes - sb-impl::step-form - sb-impl::step-values - sb-impl::stringify-package-designator - sb-impl::stringify-string-designator - sb-impl::stringify-string-designators - sb-impl::unencapsulate-generic-function) - ;; The following functions are in fact defined during make-host-2 - ;; but they are non-toplevel so they appear to be undefined. - (sb-int:gensymify* - sb-int:keywordicate - sb-int:package-symbolicate - sb-int:symbolicate - sb-kernel::preinform-compiler-about-accessors - sb-kernel::preinform-compiler-about-slot-functions - sb-impl::bytes-per-utf8-character-aref - sb-impl::bytes-per-utf8-character-sap-ref-8 - sb-impl::user-homedir-namestring - sb-c::apply-core-fixups - sb-c::compiled-debug-info-char-offset - sb-c::compiled-debug-info-tlf-number - sb-c::fopcompilable-p - sb-c::pack-xref-data - sb-c::prepare-for-compile - sb-sys:reinit-internal-real-time)) diff -Nru sbcl-2.1.1/run-sbcl.sh sbcl-2.1.11/run-sbcl.sh --- sbcl-2.1.1/run-sbcl.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/run-sbcl.sh 2021-11-30 16:16:46.000000000 +0000 @@ -15,8 +15,18 @@ this="$0" +build_directory_p(){ + [ -x "$1"/src/runtime/sbcl -a -f "$1"/output/sbcl.core ]; +} + # OSX 10.8 readlink doesn't have -f while [ -h "$this" ]; do + # Stop resolving symlinks when $this lives in a build tree. + # (Build trees might consist of symlinks to something that doesn't + # follow our repo layout.) + if build_directory_p `dirname "$this"`; then + break + fi # [ -h should guarantee that readlink output will be non-null link=`readlink -n "$this"` # if absolute path @@ -27,6 +37,14 @@ fi done BASE=`dirname "$this"` +# BASE can still be relative if $0 is a relative pathname naming a +# non-symlink, or if the last symlink visited in that loop has a +# relative target. We need BASE to be an absolute pathname in order to +# make MODULE-PROVIDE-CONTRIB work throughout the Lisp session, even +# after frobbing *DEFAULT-PATHNAME-DEFAULTS*. +if expr "$BASE" : '^/.*' > /dev/null; [ $? != 0 ]; then + BASE=`cd "$BASE" && pwd` +fi CORE_DEFINED=no @@ -47,15 +65,17 @@ esac done -ARGUMENTS="" - if [ "$CORE_DEFINED" = "no" ]; then - ARGUMENTS="--core "$BASE"/output/sbcl.core" + CORE="$BASE"/output/sbcl.core fi -if [ -x "$BASE"/src/runtime/sbcl -a -f "$BASE"/output/sbcl.core ]; then +if build_directory_p "$BASE"; then export SBCL_HOME - SBCL_HOME="$BASE/obj/sbcl-home" exec "$BASE"/src/runtime/sbcl $ARGUMENTS "$@" + if [ "$CORE_DEFINED" = "no" ]; then + SBCL_HOME="$BASE"/obj/sbcl-home exec "$BASE"/src/runtime/sbcl --core "$CORE" "$@" + else + SBCL_HOME="$BASE"/obj/sbcl-home exec "$BASE"/src/runtime/sbcl "$@" + fi else echo "No built SBCL here ($BASE): run 'sh make.sh' first!" exit 1 diff -Nru sbcl-2.1.1/slam.sh sbcl-2.1.11/slam.sh --- sbcl-2.1.1/slam.sh 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/slam.sh 2021-11-30 16:16:46.000000000 +0000 @@ -70,6 +70,9 @@ shift fi +# Load our build configuration +. output/build-config + HOST_TYPE="${1:-sbcl}" echo //HOST_TYPE=\"$HOST_TYPE\" @@ -85,7 +88,7 @@ INIT="-noinit" CORE="-core" ;; - sbcl) LISP="${XC_LISP:-sbcl}" + sbcl) LISP="${SBCL_XC_HOST:-sbcl}" INIT="--no-sysinit --no-userinit" CORE="--core" ;; diff -Nru sbcl-2.1.1/src/assembly/arm/support.lisp sbcl-2.1.11/src/assembly/arm/support.lisp --- sbcl-2.1.1/src/assembly/arm/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -75,7 +75,3 @@ :offset lip-offset) :offset 2))) (:none))) - -#-sb-xc-host ; CONTEXT-REGISTER is not defined at xc-time -(defun return-machine-address (scp) - (context-register scp lr-offset)) diff -Nru sbcl-2.1.1/src/assembly/arm64/alloc.lisp sbcl-2.1.11/src/assembly/arm64/alloc.lisp --- sbcl-2.1.1/src/assembly/arm64/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm64/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -5,7 +5,7 @@ (:translate ensure-symbol-tls-index) (:result-types positive-fixnum) (:policy :fast-safe)) - ((:arg symbol (descriptor-reg) r0-offset) + ((:arg symbol (descriptor-reg) r8-offset) (:temp free-tls-index (non-descriptor-reg) nl1-offset) (:res result (unsigned-reg) nl0-offset)) diff -Nru sbcl-2.1.1/src/assembly/arm64/array.lisp sbcl-2.1.11/src/assembly/arm64/array.lisp --- sbcl-2.1.1/src/assembly/arm64/array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm64/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -17,35 +17,32 @@ (:arg-types positive-fixnum positive-fixnum positive-fixnum)) - ((:arg type any-reg r0-offset) + ((:arg type any-reg r2-offset) (:arg length any-reg r1-offset) - (:arg words any-reg r2-offset) + (:arg words any-reg r0-offset) (:res result descriptor-reg r0-offset) (:temp ndescr non-descriptor-reg nl2-offset) (:temp pa-flag non-descriptor-reg nl3-offset) (:temp lra-save non-descriptor-reg nl5-offset) - (:temp vector descriptor-reg r8-offset) (:temp lr interior-reg lr-offset)) (pseudo-atomic (pa-flag) (inst lsl ndescr words (- word-shift n-fixnum-tag-bits)) (inst add ndescr ndescr (* (1+ vector-data-offset) n-word-bytes)) (inst and ndescr ndescr (bic-mask lowtag-mask)) ; double-word align (move lra-save lr) ;; The call to alloc_tramp will overwrite LR - (allocation nil ndescr other-pointer-lowtag vector + (allocation nil ndescr other-pointer-lowtag result :flag-tn pa-flag :lip nil) ;; keep LR intact as per above (move lr lra-save) (inst lsr ndescr type n-fixnum-tag-bits) - (storew ndescr vector 0 other-pointer-lowtag) ;; Touch the last element, to ensure that null-terminated strings ;; passed to C do not cause a WP violation in foreign code. ;; Do that before storing length, since nil-arrays don't have any ;; space, but may have non-zero length. #-gencgc (storew zr-tn pa-flag -1) - (storew length vector vector-length-slot other-pointer-lowtag) - (move result vector))) + (storew-pair ndescr 0 length vector-length-slot tmp-tn))) (define-assembly-routine (allocate-vector-on-stack (:policy :fast-safe) @@ -63,16 +60,15 @@ (inst lsl words words (- word-shift n-fixnum-tag-bits)) (inst add words words (* (1+ vector-data-offset) n-word-bytes)) (inst and words words (bic-mask lowtag-mask)) ; double-word align - (allocation nil words nil result :stack-allocate-p t) + (allocation nil words other-pointer-lowtag result :stack-allocate-p t) - (inst stp temp length (@ result)) + (inst stp temp length (@ tmp-tn)) ;; Zero fill (assemble () ;; The header word has already been set, skip it. - (inst add temp result (* n-word-bytes 2)) - (inst add words result words) + (inst add temp tmp-tn (* n-word-bytes 2)) + (inst add words tmp-tn words) LOOP (inst stp zr-tn zr-tn (@ temp (* n-word-bytes 2) :post-index)) (inst cmp temp words) - (inst b :lt LOOP)) - (inst orr result result other-pointer-lowtag))) + (inst b :lt LOOP)))) diff -Nru sbcl-2.1.1/src/assembly/arm64/assem-rtns.lisp sbcl-2.1.11/src/assembly/arm64/assem-rtns.lisp --- sbcl-2.1.1/src/assembly/arm64/assem-rtns.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm64/assem-rtns.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,7 +11,7 @@ ((:temp nvals any-reg nargs-offset) (:temp vals any-reg nl1-offset) (:temp old-fp any-reg nl2-offset) - (:temp lra descriptor-reg r6-offset) + (:temp lra interior-reg lr-offset) ;; These are just needed to facilitate the transfer (:temp count any-reg nl3-offset) @@ -23,8 +23,7 @@ (:temp r0 descriptor-reg r0-offset) (:temp r1 descriptor-reg r1-offset) (:temp r2 descriptor-reg r2-offset) - (:temp r3 descriptor-reg r3-offset) - (:temp lip interior-reg lr-offset)) + (:temp r3 descriptor-reg r3-offset)) ;; Note, because of the way the return-multiple vop is written, we ;; can assume that we are never called with nvals == 1 (not that it @@ -69,11 +68,50 @@ (inst add csp-tn ocfp-tn (lsl nvals (- word-shift n-fixnum-tag-bits))) ;; Return. - (lisp-return lra lip :multiple-values)) + (lisp-return lra :multiple-values)) ;;;; tail-call-variable. +(defun prepare-for-tail-call-variable (nargs args count dest temp r0 r1 r2 r3) + (assemble () + ;; We're in a tail-call scenario, so we use the existing LRA and + ;; OCFP, both already set up in the stack frame. We have a set of + ;; arguments, represented as the address of the first argument + ;; (ARGS) and the address just beyond the last argument (CSP-TN), + ;; and need to set up the arg-passing-registers, any stack arguments + ;; (the fourth and subsequent arguments, if such exist), and the + ;; total arg count (NARGS). + + ;; Calculate NARGS + (inst sub nargs csp-tn args) + + ;; Load the argument regs (must do this now, 'cause the blt might + ;; trash these locations, and we need ARGS to be dead for the blt) + (inst ldp r0 r1 (@ args)) + (inst ldp r2 r3 (@ args (* n-word-bytes 2))) + + ;; ARGS is now dead, we access the remaining arguments by offset + ;; from CSP-TN. + + ;; Figure out how many arguments we really need to shift. + (inst subs count nargs (* register-arg-count n-word-bytes)) + ;; If there aren't any stack args then we're done. + (inst b :le DONE) + + ;; Find where our shifted arguments need to go. + (inst add dest cfp-tn nargs) + + (inst neg count count) + LOOP + ;; Copy one arg. + (inst ldr temp (@ csp-tn count)) + (inst str temp (@ dest count)) + (inst adds count count n-word-bytes) + (inst b :ne LOOP) + + DONE + (inst asr nargs nargs (- word-shift n-fixnum-tag-bits)))) -#+sb-assembling ;; no vop for this one either. +#+sb-assembling (define-assembly-routine (tail-call-variable (:return-style :none)) @@ -88,7 +126,7 @@ ;; These are needed by the blitting code. (:temp dest any-reg nl2-offset) ;; Not live concurrent with ARGS. (:temp count any-reg nl3-offset) - (:temp temp descriptor-reg r8-offset) + (:temp temp descriptor-reg r9-offset) (:temp lip interior-reg lr-offset) ;; These are needed so we can get at the register args. @@ -97,56 +135,105 @@ (:temp r2 descriptor-reg r2-offset) (:temp r3 descriptor-reg r3-offset)) - ;; We're in a tail-call scenario, so we use the existing LRA and - ;; OCFP, both already set up in the stack frame. We have a set of - ;; arguments, represented as the address of the first argument - ;; (ARGS) and the address just beyond the last argument (CSP-TN), - ;; and need to set up the arg-passing-registers, any stack arguments - ;; (the fourth and subsequent arguments, if such exist), and the - ;; total arg count (NARGS). - - ;; Calculate NARGS - (inst sub nargs csp-tn args) - - ;; Load the argument regs (must do this now, 'cause the blt might - ;; trash these locations, and we need ARGS to be dead for the blt) - (inst ldp r0 r1 (@ args)) - (inst ldp r2 r3 (@ args (* n-word-bytes 2))) - - ;; ARGS is now dead, we access the remaining arguments by offset - ;; from CSP-TN. - - ;; Figure out how many arguments we really need to shift. - (inst subs count nargs (* register-arg-count n-word-bytes)) - ;; If there aren't any stack args then we're done. - (inst b :le DONE) + (prepare-for-tail-call-variable nargs args count dest temp r0 r1 r2 r3) + (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump temp lip)) - ;; Find where our shifted arguments need to go. - (inst add dest cfp-tn nargs) +#+sb-assembling +(define-assembly-routine + (tail-call-callable-variable + (:return-style :none)) - (inst neg count count) - LOOP - ;; Copy one arg. - (inst ldr temp (@ csp-tn count)) - (inst str temp (@ dest count)) - (inst adds count count n-word-bytes) - (inst b :ne LOOP) + ;; These are really args. + ((:temp args any-reg nl2-offset) + (:temp lexenv descriptor-reg lexenv-offset) - DONE - ;; The call frame is all set up, so all that remains is to jump to - ;; the new function. We need a boxed register to hold the actual - ;; function object (in case of closure functions or funcallable - ;; instances) - (inst asr nargs nargs (- word-shift n-fixnum-tag-bits)) + ;; We need to compute this + (:temp nargs any-reg nargs-offset) + + ;; These are needed by the blitting code. + (:temp dest any-reg nl2-offset) ;; Not live concurrent with ARGS. + (:temp count any-reg nl3-offset) + (:temp temp descriptor-reg r9-offset) + (:temp lip interior-reg lr-offset) + + ;; These are needed so we can get at the register args. + (:temp r0 descriptor-reg r0-offset) + (:temp r1 descriptor-reg r1-offset) + (:temp r2 descriptor-reg r2-offset) + (:temp r3 descriptor-reg r3-offset)) + + (prepare-for-tail-call-variable nargs args count dest temp r0 r1 r2 r3) + (inst and tmp-tn lexenv lowtag-mask) + (inst cmp tmp-tn fun-pointer-lowtag) + (inst b :eq call) + (inst b (make-fixup 'tail-call-symbol :assembly-routine)) + call (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) (lisp-jump temp lip)) + +#+sb-assembling +(define-assembly-routine (call-symbol + (:return-style :none) + (:export tail-call-symbol)) + ((:temp fun (any-reg descriptor-reg) lexenv-offset) + (:temp length (any-reg descriptor-reg) nl0-offset) + (:temp packed-info (any-reg descriptor-reg) r7-offset) + (:temp temp (any-reg descriptor-reg) nl1-offset) + (:temp temp2 (any-reg descriptor-reg) nl2-offset)) + (inst str lr-tn (@ cfp-tn 8)) + TAIL-CALL-SYMBOL + (inst and temp fun lowtag-mask) + (inst cmp temp other-pointer-lowtag) + (inst b :ne not-callable) + + (inst ldrb temp (@ fun (- other-pointer-lowtag))) + (inst cmp temp symbol-widetag) + (inst b :ne not-callable) + + (load-symbol-dbinfo packed-info fun temp) + + ;; packed-info-fdefn + (inst cmp packed-info null-tn) + (inst b :eq undefined) + + ;; read the 0th info descriptor + (inst ldr temp (@ packed-info + (- (ash (+ instance-slots-offset instance-data-start) word-shift) + instance-pointer-lowtag))) + (inst and temp temp (fixnumize (1- (ash 1 (* info-number-bits 2))))) + (inst movz temp2 (fixnumize (1+ (ash +fdefn-info-num+ info-number-bits)))) + (inst cmp temp temp2) + (inst b :lt undefined) + + ;; read the instance-length and mask out the extra bits + (inst ldr length (@ packed-info (- instance-pointer-lowtag))) + ;; these next two instructions should be one 'ubfx' but I'm not smart enough + (inst lsr length length instance-length-shift) + (inst and length length instance-length-mask) + (inst lsl length length word-shift) + + (inst sub length length instance-pointer-lowtag) + (inst ldr fun (@ packed-info length)) + (loadw lr-tn fun fdefn-raw-addr-slot other-pointer-lowtag) + (inst add lr-tn lr-tn 4) + (inst br lr-tn) + UNDEFINED + (inst b (make-fixup 'undefined-tramp :assembly-routine)) + NOT-CALLABLE + (inst cmp fun null-tn) ;; NIL doesn't have SYMBOL-WIDETAG + (inst b :eq undefined) + + (emit-error-break nil error-trap (error-number-or-lose 'sb-kernel::object-not-callable-error) + (list fun))) + ;;;; Non-local exit noise. (define-assembly-routine (throw - (:return-style :none)) + (:return-style :none)) ((:arg target descriptor-reg r0-offset) - (:arg start any-reg r8-offset) + (:arg start any-reg r9-offset) (:arg count any-reg nargs-offset) (:temp catch any-reg r1-offset) (:temp tag descriptor-reg r2-offset)) @@ -156,7 +243,18 @@ LOOP - (let ((error (generate-error-code nil 'unseen-throw-tag-error target))) + (let ((error (gen-label))) + (assemble (:elsewhere) + (emit-label error) + + ;; Fake up a stack frame so that backtraces come out right. + (inst mov ocfp-tn cfp-tn) + (inst mov cfp-tn csp-tn) + (inst stp ocfp-tn lr-tn (@ csp-tn 16 :post-index)) + + (emit-error-break nil error-trap + (error-number-or-lose 'unseen-throw-tag-error) + (list target))) (inst cbz catch error)) (loadw-pair tmp-tn catch-block-previous-catch-slot tag catch-block-tag-slot catch) @@ -169,14 +267,13 @@ (inst b (make-fixup 'unwind :assembly-routine))) (define-assembly-routine (unwind - (:return-style :none) (:translate %unwind) - (:policy :fast-safe)) + (:policy :fast-safe) + (:return-style :none)) ((:arg block (any-reg descriptor-reg) r0-offset) - (:arg start (any-reg descriptor-reg) r8-offset) + (:arg start (any-reg descriptor-reg) r9-offset) (:arg count (any-reg descriptor-reg) nargs-offset) (:temp ocfp any-reg ocfp-offset) - (:temp lra descriptor-reg lexenv-offset) (:temp cur-uwp any-reg nl2-offset) (:temp lip interior-reg lr-offset) (:temp next-uwp any-reg nl3-offset) @@ -184,31 +281,58 @@ (:temp where any-reg r1-offset) (:temp symbol descriptor-reg r2-offset) (:temp value descriptor-reg r3-offset)) - (declare (ignore start count)) + AGAIN (let ((error (generate-error-code nil 'invalid-unwind-error))) (inst cbz block error)) (load-tl-symbol-value cur-uwp *current-unwind-protect-block*) (loadw ocfp block unwind-block-uwp-slot) - (inst mov next-uwp cur-uwp) (inst cmp cur-uwp ocfp) - (inst b :eq EQ) - (loadw next-uwp cur-uwp unwind-block-uwp-slot) - EQ - (inst csel cur-uwp block cur-uwp :eq) + (inst b :eq DO-EXIT) + + (inst stp block start (@ csp-tn 32 :post-index)) + (inst adr next-uwp RET) ;; Avoids saving the link register on uwp entry + (inst stp count next-uwp (@ csp-tn -16)) + + ;; Need to perform unbinding before unlinking the UWP so that if + ;; interrupted here it can still run the clean up form. While the + ;; cleanup form itself cannot be protected from interrupts (can't + ;; run it twice) one of the variables being unbound can be + ;; *interrupts-enabled* (loadw where cur-uwp unwind-block-bsp-slot) (unbind-to-here where symbol value tmp-tn) + ;; Set next unwind protect context. + + (loadw next-uwp cur-uwp unwind-block-uwp-slot) (store-tl-symbol-value next-uwp *current-unwind-protect-block*) - (loadw-pair cfp-tn unwind-block-cfp-slot code-tn unwind-block-code-slot cur-uwp) + (loadw-pair cfp-tn unwind-block-cfp-slot lip unwind-block-entry-pc-slot cur-uwp) (loadw next-uwp cur-uwp unwind-block-current-catch-slot) (store-tl-symbol-value next-uwp *current-catch-block*) + (loadw-pair (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset nfp-offset) + unwind-block-nfp-slot next-uwp unwind-block-nsp-slot cur-uwp) + (inst mov-sp nsp-tn next-uwp) + (inst br lip) + RET + (inst ldr count (@ csp-tn -8 :pre-index)) + (inst ldp block start (@ csp-tn -16 :pre-index)) + (inst b AGAIN) - (loadw-pair tmp-tn unwind-block-nfp-slot next-uwp unwind-block-nsp-slot cur-uwp) + DO-EXIT + (loadw where block unwind-block-bsp-slot) + (unbind-to-here where symbol value tmp-tn) + (loadw-pair cfp-tn unwind-block-cfp-slot lip unwind-block-entry-pc-slot block) + (loadw next-uwp block unwind-block-current-catch-slot) + (store-tl-symbol-value next-uwp *current-catch-block*) + (loadw-pair (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset nfp-offset) + unwind-block-nfp-slot next-uwp unwind-block-nsp-slot block) (inst mov-sp nsp-tn next-uwp) - (inst cbz tmp-tn SKIP) - (inst mov (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset nfp-offset) tmp-tn) - SKIP - (loadw lra cur-uwp unwind-block-entry-pc-slot) - (lisp-return lra lip :known)) + (inst br lip)) + +(define-vop () + (:translate %continue-unwind) + (:policy :fast-safe) + (:generator 0 + (inst ldr lr-tn (@ csp-tn -8 :pre-index)) + (inst ret))) diff -Nru sbcl-2.1.1/src/assembly/arm64/support.lisp sbcl-2.1.11/src/assembly/arm64/support.lisp --- sbcl-2.1.1/src/assembly/arm64/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm64/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -19,7 +19,7 @@ `((progn ,@(if (eq style :none) `((load-inline-constant tmp-tn '(:fixup ,name :assembly-routine)) - (inst br tmp-tn)) + (inst blr tmp-tn)) `((load-inline-constant lr-tn '(:fixup ,name :assembly-routine)) (inst blr lr-tn))))) nil)) @@ -72,7 +72,3 @@ :offset lip-offset) :offset 2))) (:none))) - -#-sb-xc-host ; CONTEXT-REGISTER is not defined at xc-time -(defun return-machine-address (scp) - (context-register scp lr-offset)) diff -Nru sbcl-2.1.1/src/assembly/arm64/tramps.lisp sbcl-2.1.11/src/assembly/arm64/tramps.lisp --- sbcl-2.1.1/src/assembly/arm64/tramps.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/arm64/tramps.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -52,9 +52,7 @@ (map-pairs stp nsp-tn 0 nl-registers :pre-index -80) (inst mov nl0 tmp-tn) ;; size #+sb-thread - (progn - (inst stp cfp-tn csp-tn (@ thread-tn (* thread-control-frame-pointer-slot n-word-bytes))) - (inst str csp-tn (@ thread-tn (* thread-foreign-function-call-active-slot n-word-bytes)))) + (inst stp cfp-tn csp-tn (@ thread-tn (* thread-control-frame-pointer-slot n-word-bytes))) #-sb-thread (progn ;; Each of these loads of a fixup loads the address of a linkage table entry, @@ -78,8 +76,7 @@ (inst str (32-bit-reg null-tn) (@ nl1))) ; (alien variable is 4 bytes, not 8) ;; Create a new frame (inst add csp-tn csp-tn (+ 32 80)) - (inst stp cfp-tn null-tn (@ csp-tn -112)) - (inst stp code-tn lr-tn (@ csp-tn -96)) + (inst stp cfp-tn lr-tn (@ csp-tn -112)) (map-pairs stp csp-tn -80 lisp-registers) (map-pairs stp nsp-tn 0 float-registers :pre-index -512 :delta 32) @@ -90,11 +87,11 @@ (map-pairs ldp nsp-tn 480 float-registers :post-index 512 :delta -32) (map-pairs ldp csp-tn -16 lisp-registers :delta -16) - (inst ldr lr-tn (@ csp-tn -88)) + (inst ldr lr-tn (@ csp-tn -104)) (inst sub csp-tn csp-tn (+ 32 80)) ;; deallocate the frame #+sb-thread - (inst str zr-tn (@ thread-tn (* thread-foreign-function-call-active-slot n-word-bytes))) + (inst str zr-tn (@ thread-tn (* thread-control-stack-pointer-slot n-word-bytes))) #-sb-thread (progn ;; We haven't restored NL1 yet, so it's ok to use as a scratch register here. @@ -117,7 +114,7 @@ (undefined-tramp-tagged (+ xundefined-tramp fun-pointer-lowtag)))) - () + ((:temp fun any-reg r9-offset)) HEADER (inst dword simple-fun-widetag) (inst dword (make-fixup 'undefined-tramp-tagged @@ -126,12 +123,12 @@ (inst dword nil-value)) UNDEFINED-TRAMP - (inst adr code-tn header fun-pointer-lowtag) + (inst str lr-tn (@ cfp-tn 8)) (emit-error-break nil cerror-trap (error-number-or-lose 'undefined-fun-error) (list lexenv-tn)) - (loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag) - (inst add lr-tn code-tn (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag)) - + (loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag) + (inst add lr-tn fun (+ (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag) + 4)) (inst br lr-tn)) (define-assembly-routine @@ -141,7 +138,7 @@ (undefined-alien-tramp-tagged (+ xundefined-alien-tramp fun-pointer-lowtag)))) - ((:temp r8-tn unsigned-reg r8-offset)) + ((:temp r9-tn unsigned-reg r9-offset)) HEADER (inst dword simple-fun-widetag) (inst dword (make-fixup 'undefined-alien-tramp-tagged @@ -150,8 +147,8 @@ (inst dword nil-value)) UNDEFINED-ALIEN-TRAMP - (inst adr code-tn header fun-pointer-lowtag) - (error-call nil 'undefined-alien-fun-error r8-tn)) + (inst str lr-tn (@ cfp-tn 8)) + (error-call nil 'undefined-alien-fun-error r9-tn)) (define-assembly-routine (xclosure-tramp (:return-style :none) @@ -160,7 +157,7 @@ (closure-tramp-tagged (+ xclosure-tramp fun-pointer-lowtag)))) - () + ((:temp fun any-reg r9-offset)) (inst dword simple-fun-widetag) (inst dword (make-fixup 'closure-tramp-tagged :assembly-routine)) @@ -168,9 +165,11 @@ (inst dword nil-value)) CLOSURE-TRAMP + (inst str lr-tn (@ cfp-tn 8)) (loadw lexenv-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag) - (loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag) - (inst add lr-tn code-tn (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag)) + (loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag) + (inst add lr-tn fun (+ (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag) + 4)) (inst br lr-tn)) (define-assembly-routine @@ -179,13 +178,14 @@ (:export (funcallable-instance-tramp (+ xfuncallable-instance-tramp fun-pointer-lowtag)))) - () + ((:temp fun any-reg r9-offset)) (inst dword simple-fun-widetag) (inst dword (make-fixup 'funcallable-instance-tramp :assembly-routine)) (dotimes (i (- simple-fun-insts-offset 2)) (inst dword nil-value)) - + (inst str lr-tn (@ cfp-tn 8)) (loadw lexenv-tn lexenv-tn funcallable-instance-function-slot fun-pointer-lowtag) - (loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag) - (inst add lr-tn code-tn (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag)) + (loadw fun lexenv-tn closure-fun-slot fun-pointer-lowtag) + (inst add lr-tn fun (+ (- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag) + 4)) (inst br lr-tn)) diff -Nru sbcl-2.1.1/src/assembly/assemfile.lisp sbcl-2.1.11/src/assembly/assemfile.lisp --- sbcl-2.1.1/src/assembly/assemfile.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/assemfile.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -68,6 +68,7 @@ (dump-assembler-routines segment (segment-buffer segment) (sb-assem::segment-fixup-notes segment) + (sb-assem::get-allocation-points asmstream) *entry-points* lap-fasl-output)) (setq won t)) diff -Nru sbcl-2.1.1/src/assembly/master.lisp sbcl-2.1.11/src/assembly/master.lisp --- sbcl-2.1.1/src/assembly/master.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/master.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1,10 +1,7 @@ ;; If you change this, note that 'slam.lisp' has to be able to parse this form -(mapc (lambda (x) - (load (merge-pathnames (stem-remap-target x) - (make-pathname :type "lisp")) - :verbose nil :print nil)) - '("src/assembly/target/tramps" - "src/assembly/target/assem-rtns" - "src/assembly/target/array" - "src/assembly/target/arith" - "src/assembly/target/alloc")) +(mapc (lambda (x) (load (sb-cold:stem-source-path x) :verbose nil :print nil)) + '("src/assembly/{arch}/tramps" + "src/assembly/{arch}/assem-rtns" + "src/assembly/{arch}/array" + "src/assembly/{arch}/arith" + "src/assembly/{arch}/alloc")) diff -Nru sbcl-2.1.1/src/assembly/mips/support.lisp sbcl-2.1.11/src/assembly/mips/support.lisp --- sbcl-2.1.1/src/assembly/mips/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/mips/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -65,7 +65,3 @@ :offset lra-offset) lip-tn :offset 2))) (:none))) - -#-sb-xc-host ; CONTEXT-REGISTER is not defined at xc-time -(defun return-machine-address (scp) - (context-register scp lip-offset)) diff -Nru sbcl-2.1.1/src/assembly/mips/tramps.lisp sbcl-2.1.11/src/assembly/mips/tramps.lisp --- sbcl-2.1.1/src/assembly/mips/tramps.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/mips/tramps.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,6 +14,7 @@ fun-pointer-lowtag)))) ((:temp nl0 unsigned-reg nl0-offset) (:temp lra descriptor-reg lra-offset)) + (progn nl0) ; "use" it. Don't know if it's needed, and don't care to know. (inst word simple-fun-widetag) (inst word (make-fixup 'undefined-tramp-tagged :assembly-routine)) diff -Nru sbcl-2.1.1/src/assembly/ppc/support.lisp sbcl-2.1.11/src/assembly/ppc/support.lisp --- sbcl-2.1.1/src/assembly/ppc/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/ppc/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -68,7 +68,3 @@ :offset lip-offset) :offset 2))) (:none))) - -#-sb-xc-host ; CONTEXT-LR is not defined at xc-time -(defun return-machine-address (scp) - (sap-int (context-lr scp))) diff -Nru sbcl-2.1.1/src/assembly/ppc64/support.lisp sbcl-2.1.11/src/assembly/ppc64/support.lisp --- sbcl-2.1.1/src/assembly/ppc64/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/ppc64/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -68,7 +68,3 @@ :offset lip-offset) :offset 2))) (:none))) - -#-sb-xc-host ; CONTEXT-LR is not defined at xc-time -(defun return-machine-address (scp) - (sap-int (context-lr scp))) diff -Nru sbcl-2.1.1/src/assembly/riscv/support.lisp sbcl-2.1.11/src/assembly/riscv/support.lisp --- sbcl-2.1.1/src/assembly/riscv/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/riscv/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -29,11 +29,3 @@ (:none) (:raw `((inst jalr zero-tn lip-tn 0))))) - -#-sb-xc-host ; CONTEXT-REGISTER is not defined at xc-time -(defun return-machine-address (scp) - ;; KLUDGE: Taken from SPARC backend. Why does `8' need to be added - ;; to the return address? Without it, backtraces get truncated and - ;; are incorrect. Are the other backends wrong as well by not adding - ;; 8? - (+ (context-register scp lip-offset) 8)) diff -Nru sbcl-2.1.1/src/assembly/sparc/array.lisp sbcl-2.1.11/src/assembly/sparc/array.lisp --- sbcl-2.1.1/src/assembly/sparc/array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/sparc/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,7 +13,6 @@ (define-assembly-routine (allocate-vector-on-heap (:policy :fast-safe) - (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) @@ -57,7 +56,6 @@ (define-assembly-routine (allocate-vector-on-stack (:policy :fast-safe) - (:translate allocate-vector) (:arg-types positive-fixnum positive-fixnum positive-fixnum)) diff -Nru sbcl-2.1.1/src/assembly/sparc/support.lisp sbcl-2.1.11/src/assembly/sparc/support.lisp --- sbcl-2.1.1/src/assembly/sparc/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/sparc/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -70,7 +70,3 @@ :offset lra-offset) :offset 2))) (:none))) - -#-sb-xc-host ; CONTEXT-REGISTER is not defined at xc-time -(defun return-machine-address (scp) - (+ (context-register scp lip-offset) 8)) diff -Nru sbcl-2.1.1/src/assembly/x86/alloc.lisp sbcl-2.1.11/src/assembly/x86/alloc.lisp --- sbcl-2.1.1/src/assembly/x86/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -50,11 +50,11 @@ `((inst mov ,scratch-tn (make-ea :dword :disp +win32-tib-arbitrary-field-offset+) :fs) - (inst sub ,reg (make-ea :dword :disp (ash thread-alloc-region-slot 2) + (inst sub ,reg (make-ea :dword :disp (ash thread-boxed-tlab-slot 2) :base ,scratch-tn)))) #-win32 `(#+sb-thread (inst sub ,reg - (make-ea :dword :disp (ash thread-alloc-region-slot 2)) + (make-ea :dword :disp (ash thread-boxed-tlab-slot 2)) :fs) #-sb-thread (inst sub ,reg (make-ea :dword :disp boxed-region)))))) diff -Nru sbcl-2.1.1/src/assembly/x86/assem-rtns.lisp sbcl-2.1.11/src/assembly/x86/assem-rtns.lisp --- sbcl-2.1.1/src/assembly/x86/assem-rtns.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86/assem-rtns.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -482,77 +482,6 @@ (inst mov eax-tn 1) ;; exception-continue-search (inst ret)) -#+sb-assembling -(define-assembly-routine (code-header-set (:return-style :none)) () - (inst push eax-tn) - (inst push edx-tn) - (inst push edi-tn) - ;; stack: spill[3], ret-pc, object, index, value-to-store - - (symbol-macrolet ((object (make-ea :dword :base esp-tn :disp 16)) - (word-index (make-ea :dword :base esp-tn :disp 20)) - (newval (make-ea :dword :base esp-tn :disp 24)) - (prefix #+(and sb-thread (not win32)) :fs - #-(and sb-thread (not win32)) nil)) - (flet ((thread-slot-ea (slot-index) - (make-ea :dword - #+(or (not sb-thread) win32) :base #+(or (not sb-thread) win32) edi-tn - :disp (ash slot-index word-shift)))) - #-sb-thread - (progn - ;; Load 'all_threads' into EDI (which was already spilled) - ;; as the register with which to access thread slots. - (inst mov edi-tn - (make-ea :dword :disp (make-fixup "all_threads" :foreign-dataref))) - (inst mov edi-tn (make-ea :dword :base edi-tn))) - #+(and win32 sb-thread) - (inst mov edi-tn (make-ea :dword :disp +win32-tib-arbitrary-field-offset+) :fs) - - (inst mov eax-tn object) ; object - (inst sub eax-tn (thread-slot-ea thread-dynspace-addr-slot) prefix) - (inst shr eax-tn (1- (integer-length gencgc-card-bytes))) - (pseudo-atomic () - (assemble () - (inst cmp eax-tn (thread-slot-ea thread-dynspace-card-count-slot) - prefix) - (inst jmp :ae STORE) ; not dynamic space - ;; sizeof (struct page) depends on GENCGC-CARD-BYTES - ;; It's 4+2+1+1 = 8 bytes if GENCGC-CARD-BYTES is (unsigned-byte 16), - ;; or 4+4+1+1 = 10 bytes (rounded to 12) if wider than (unsigned-byte 16). - ;; See the corresponding alien structure definition in 'room.lisp' - (cond ((typep gencgc-card-bytes '(unsigned-byte 16)) - (inst shl eax-tn 3) ; multiply by 8 - (inst add eax-tn (thread-slot-ea thread-dynspace-pte-base-slot) - prefix) - ;; clear WP - bit index 5 of flags byte - (inst and (make-ea :byte :base eax-tn :disp 6) (lognot (ash 1 5)) - :lock)) - (t - (inst lea eax-tn ; multiply by 3 - (make-ea :dword :base eax-tn :index eax-tn :scale 2)) - (inst shl eax-tn 2) ; then by 4, = 12 - (inst add eax-tn (thread-slot-ea thread-dynspace-pte-base-slot) - prefix) - ;; clear WP - (inst and (make-ea :byte :base eax-tn :disp 8) (lognot (ash 1 5)) - :lock))) - STORE - (inst mov edi-tn object) - (inst mov edx-tn word-index) - (inst mov eax-tn newval) - ;; set 'written' flag in the code header - (inst or (make-ea :byte :base edi-tn :disp (- 3 other-pointer-lowtag)) - #x40 :lock) - ;; store newval into object - (inst mov (make-ea :dword :base edi-tn - :index edx-tn :scale (ash 1 word-shift) - :disp (- other-pointer-lowtag)) - eax-tn))))) - (inst pop edi-tn) ; restore - (inst pop edx-tn) - (inst pop eax-tn) - (inst ret 12)) ; remove 3 stack args - #| Turns out that setting the direction flag not only requires trapping into microcode, but also prevents the processor from using its fast REP diff -Nru sbcl-2.1.1/src/assembly/x86-64/alloc.lisp sbcl-2.1.11/src/assembly/x86-64/alloc.lisp --- sbcl-2.1.1/src/assembly/x86-64/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -17,44 +17,60 @@ ;;;; fixnum cases inline. #+sb-assembling (macrolet - ((signed (reg avx) - `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg - (if avx "-AVX2" ""))) + ((signed (reg) + `(define-assembly-routine (,(symbolicate "ALLOC-SIGNED-BIGNUM-IN-" reg)) ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET"))) - (inst push number) - (let (#+avx2 - (*avx-registers-used-p* ,avx)) - (alloc-other number bignum-widetag (+ bignum-digits-offset 1) nil)) - (popw number bignum-digits-offset other-pointer-lowtag))) - (unsigned (reg avx) - `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg - (if avx "-AVX2" ""))) + ,@(cond + ((eq reg 'r12) ; problematic case for INSTRUMENT-ALLOC + '((inst push rax-tn) + (alloc-other bignum-widetag (+ bignum-digits-offset 1) rax-tn nil nil nil) + (storew number rax-tn bignum-digits-offset other-pointer-lowtag) + (inst mov number rax-tn) + (inst pop rax-tn))) + (t + '((inst push number) + (alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil nil) + (popw number bignum-digits-offset other-pointer-lowtag)))))) + (unsigned (reg) + `(define-assembly-routine (,(symbolicate "ALLOC-UNSIGNED-BIGNUM-IN-" reg)) ((:temp number unsigned-reg ,(symbolicate reg "-OFFSET"))) (inst ror number (1+ n-fixnum-tag-bits)) ; restore unrotated value - (inst push number) (inst test number number) ; rotates do not update SF - (inst jmp :ns one-word-bignum) - (let (#+avx2 - (*avx-registers-used-p* ,avx)) - ;; Two word bignum - (alloc-other number bignum-widetag (+ bignum-digits-offset 2) nil)) - (popw number bignum-digits-offset other-pointer-lowtag) - (inst ret) - ONE-WORD-BIGNUM - (alloc-other number bignum-widetag (+ bignum-digits-offset 1) nil) - (popw number bignum-digits-offset other-pointer-lowtag))) - (define (op &optional avx) - ;; Don't include r11 or r13 since those are temp and thread-base respectively + ,@(cond + ((eq reg 'r12) ; problematic case for INSTRUMENT-ALLOC + '((inst push rax-tn) + (inst jmp :ns one-word-bignum) + ;; Two word bignum + (alloc-other bignum-widetag (+ bignum-digits-offset 2) rax-tn nil nil nil) + (storew number rax-tn bignum-digits-offset other-pointer-lowtag) + (inst mov number rax-tn) + (inst pop rax-tn) + (inst ret) + ONE-WORD-BIGNUM + (alloc-other bignum-widetag (+ bignum-digits-offset 1) rax-tn nil nil nil) + (storew number rax-tn bignum-digits-offset other-pointer-lowtag) + (inst mov number rax-tn) + (inst pop rax-tn))) + (t + '((inst push number) + (inst jmp :ns one-word-bignum) + ;; Two word bignum + (alloc-other bignum-widetag (+ bignum-digits-offset 2) number nil nil nil) + (popw number bignum-digits-offset other-pointer-lowtag) + (inst ret) + ONE-WORD-BIGNUM + (alloc-other bignum-widetag (+ bignum-digits-offset 1) number nil nil nil) + (popw number bignum-digits-offset other-pointer-lowtag)))))) + (define (op) + ;; R13 is usually the thread register, but might not be `(progn ,@(loop for reg in '(rax rcx rdx rbx rsi rdi - r8 r9 r10 r12 r14 r15) - collect `(,op ,reg ,avx))))) + r8 r9 r10 r11 r12 + #+gs-seg r13 + r14 r15) + collect `(,op ,reg))))) (define signed) - (define unsigned) - #+avx2 - (define signed t) - #+avx2 - (define unsigned t)) + (define unsigned)) #+sb-thread (define-assembly-routine (alloc-tls-index diff -Nru sbcl-2.1.1/src/assembly/x86-64/arith.lisp sbcl-2.1.11/src/assembly/x86-64/arith.lisp --- sbcl-2.1.1/src/assembly/x86-64/arith.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/arith.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -50,10 +50,11 @@ #+sb-assembling (defun return-single-word-bignum (dest alloc-tn source) - (instrument-alloc 16 nil) - (let ((header (logior (ash 1 n-widetag-bits) bignum-widetag))) + (let ((header (logior (ash 1 n-widetag-bits) bignum-widetag)) + (nbytes #+bignum-assertions 32 #-bignum-assertions 16)) + (instrument-alloc bignum-widetag nbytes nil alloc-tn) (pseudo-atomic () - (allocation nil 16 0 nil nil alloc-tn) + (allocation bignum-widetag nbytes 0 alloc-tn nil nil nil) (storew* header alloc-tn 0 0 t) (storew source alloc-tn bignum-digits-offset 0) (if (eq dest alloc-tn) @@ -132,7 +133,7 @@ (inst cmp x rcx) (inst jmp :e SINGLE-WORD-BIGNUM) - (alloc-other res bignum-widetag (+ bignum-digits-offset 2) nil) + (alloc-other bignum-widetag (+ bignum-digits-offset 2) res nil nil nil) (storew rax res bignum-digits-offset other-pointer-lowtag) (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag) (inst clc) (inst ret) @@ -300,30 +301,35 @@ (inst jmp :ge POSITIVE) (inst not rdx) POSITIVE)) - (unless (memq :popcnt *backend-subfeatures*) - (test-cpu-feature cpu-has-popcnt) - (inst jmp :z slow)) + (when (memq :popcnt *backend-subfeatures*) ; always use POPCNT ;; Intel's implementation of POPCNT on some models treats it as ;; a 2-operand ALU op in the manner of ADD,SUB,etc which means that ;; it falsely appears to need data from the destination register. ;; The workaround is to clear the destination. ;; See http://stackoverflow.com/questions/25078285 - (unless (location= result arg) + (unless (location= result arg) ;; We only break the spurious dep. chain if result isn't the same ;; register as arg. (If they're location=, don't trash the arg!) - (inst xor result result)) + (inst xor :dword result result)) + (inst popcnt result arg) + (return-from ,name)) + + ;; Conditionally use POPCNT + (test-cpu-feature cpu-has-popcnt) + (inst jmp :z slow) + (unless (location= result arg) + (inst xor :dword result result)) (inst popcnt result arg) (inst jmp done) slow - (unless (memq :popcnt *backend-subfeatures*) - (move rdx arg) - (invoke-asm-routine 'call 'logcount vop) - (move result rdx)) + (move rdx arg) + (invoke-asm-routine 'call 'logcount vop) + (move result rdx) done)))) (def-it unsigned-byte-64-count 14 unsigned-reg unsigned-num) (def-it signed-byte-64-count 15 signed-reg signed-num :signed t) (def-it positive-fixnum-count 12 any-reg positive-fixnum) - (def-it positive-fixnum-count 13 any-reg fixnum :signed t)) + (def-it signed-fixnum-count 13 any-reg fixnum :signed t)) ;;; General case of EQL @@ -346,8 +352,8 @@ ;;; It just doesn't seem worth the effort to do all that. (defparameter eql-dispatch nil) (define-assembly-routine (generic-eql (:return-style :none)) - ((:temp rax unsigned-reg rax-offset) - (:temp rcx unsigned-reg rcx-offset) + ((:temp rcx unsigned-reg rcx-offset) ; callee-saved + (:temp rax unsigned-reg rax-offset) ; vop temps (:temp rsi unsigned-reg rsi-offset) (:temp rdi unsigned-reg rdi-offset) (:temp r11 unsigned-reg r11-offset)) @@ -440,10 +446,24 @@ ;; as for all other objects (in byte index 3 of the header) (inst push rcx) (inst mov rcx (ea (- other-pointer-lowtag) rdi)) - (inst shl rcx 1) + (inst shl rcx 1) ; shift out GC mark bit (inst shr rcx (1+ n-widetag-bits)) - (inst jmp :z epilogue) ; zero payload length, can this happen? + #+bignum-assertions + (progn (inst mov r11 rcx) + (inst or r11 1)) ; align to start of ubsan bits compare-loop + #+bignum-assertions + (let ((ok1 (gen-label)) (ok2 (gen-label))) + (inst dec rcx) + (inst bt (ea (- n-word-bytes other-pointer-lowtag) rsi r11 8) rcx) + (inst jmp :nc ok1) + (inst break halt-trap) + (emit-label ok1) + (inst bt (ea (- n-word-bytes other-pointer-lowtag) rdi r11 8) rcx) + (inst jmp :nc ok2) + (inst break halt-trap) + (emit-label ok2) + (inst inc rcx)) (inst mov rax (ea (- other-pointer-lowtag) rsi rcx 8)) (inst cmp rax (ea (- other-pointer-lowtag) rdi rcx 8)) (inst jmp :ne epilogue) @@ -522,8 +542,6 @@ (inst cmp rcx (ea (- other-pointer-lowtag) y)) (inst jmp :ne done) (inst shr rcx n-widetag-bits) - ;; can you have 0 payload words? Probably not, but let's be safe here. - (inst jmp :z done) loop (inst mov rax (ea (- other-pointer-lowtag) x rcx 8)) (inst cmp rax (ea (- other-pointer-lowtag) y rcx 8)) diff -Nru sbcl-2.1.1/src/assembly/x86-64/array.lisp sbcl-2.1.11/src/assembly/x86-64/array.lisp --- sbcl-2.1.1/src/assembly/x86-64/array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -16,7 +16,7 @@ ;;; to deal with pre- and post-loop pieces for proper alignment. ;;; Alternatively, if the CPU has the enhanced MOVSB feature, use REP STOS ;;; depending on the number of elements to be written. -(define-assembly-routine (vector-fill/t +(define-assembly-routine (vector-fill/t ; <-- this could work on raw bits too (:translate vector-fill/t) (:policy :fast-safe)) ((:arg vector (descriptor-reg) rdx-offset) @@ -25,16 +25,46 @@ (:arg end (any-reg descriptor-reg) rsi-offset) (:res res (descriptor-reg) rdx-offset) (:temp count unsigned-reg rcx-offset) + (:temp end-card-index unsigned-reg rbx-offset) ;; storage class doesn't matter since all float regs ;; and sse regs map to the same storage base. (:temp wordpair double-reg float0-offset)) (move res vector) ; to "use" res + + ;; Mark each GC card of the vector unless ITEM is not a pointer + ;; (NIL is non-pointer) or the COUNT is 0. + (inst cmp start end) + (inst jmp :ge DONE) + (inst lea :dword count (ea -3 item)) ; same as POINTERP (see type-vops) + (inst test :byte count #b11) + (inst jmp :nz DONE-CARD-MARKING) + (inst cmp item nil-value) + (inst jmp :e DONE-CARD-MARKING) + + (let ((disp (- (ash vector-data-offset word-shift) other-pointer-lowtag)) + (card-index count) + (loop (gen-label))) + ;; Compute EA of starting and ending (inclusive) indices + (inst lea card-index (ea disp vector start (ash 1 (- word-shift n-fixnum-tag-bits)))) + (inst lea end-card-index (ea (- disp n-word-bytes) + vector end (ash 1 (- word-shift n-fixnum-tag-bits)))) + (inst shr card-index gencgc-card-shift) + (inst shr end-card-index gencgc-card-shift) + (inst and :dword card-index card-index-mask) + (inst and :dword end-card-index card-index-mask) + (emit-label LOOP) + (inst mov :byte (ea gc-card-table-reg-tn card-index) 0) ; mark one card + (inst cmp card-index end-card-index) + (inst jmp :e DONE-CARD-MARKING) + (inst inc :dword card-index) + (inst and :dword card-index card-index-mask) + (inst jmp LOOP)) + + DONE-CARD-MARKING (move count end) (inst sub count start) - ;; 'start' and 'limit' will be interior pointers into 'vector', + ;; 'start' is an interior pointer to 'vector', ;; but 'vector' is pinned because it's in a register, so this is ok. - ;; If we had a precise GC we'd want to keep start and limit as offsets - ;; because we couldn't tie them both to the vector. (inst lea start (ea (- (ash vector-data-offset word-shift) other-pointer-lowtag) vector start (ash 1 (- word-shift n-fixnum-tag-bits)))) ;; REP STOS has a fixed cost that makes it suboptimal below @@ -50,7 +80,7 @@ (inst shr count n-fixnum-tag-bits) (inst rep) - (inst stos item) + (inst stos :qword) DONE (inst ret) UNROLL diff -Nru sbcl-2.1.1/src/assembly/x86-64/assem-rtns.lisp sbcl-2.1.11/src/assembly/x86-64/assem-rtns.lisp --- sbcl-2.1.1/src/assembly/x86-64/assem-rtns.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/assem-rtns.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -229,27 +229,38 @@ #+sb-assembling (define-assembly-routine (call-symbol (:return-style :none)) - ((:temp fun (any-reg descriptor-reg) rax-offset) + ((:temp fun (any-reg descriptor-reg) rax-offset) ; FUN = the symbol (:temp length (any-reg descriptor-reg) rax-offset) - (:temp vector (any-reg descriptor-reg) rbx-offset)) - (%lea-for-lowtag-test vector fun other-pointer-lowtag) - (inst test :byte vector lowtag-mask) + (:temp info (any-reg descriptor-reg) rbx-offset)) ; for the packed symbol-info + (%lea-for-lowtag-test info fun other-pointer-lowtag) + (inst test :byte info lowtag-mask) (inst jmp :nz not-callable) (inst cmp :byte (ea (- other-pointer-lowtag) fun) symbol-widetag) (inst jmp :ne not-callable) - (load-symbol-info-vector vector fun) - ;; info-vector-fdefn - (inst cmp vector nil-value) + (load-symbol-dbinfo info fun) + ;; reimplement by hand PACKED-INFO-FDEFN, q.v. + + ;; This only has to compare the low byte of INFO, + ;; because INSTANCE-POINTER-LOWTAG won't match NIL in the low 8 bits. + (inst cmp :byte info (logand nil-value #xff)) (inst jmp :e undefined) - (inst mov :dword r10-tn (ea (- (* 2 n-word-bytes) other-pointer-lowtag) vector)) + ;; XXX - WHAT IS R10? ARBITRARY? COMMENT NEEDED + (inst mov :dword r10-tn (ea (- (ash (+ instance-slots-offset instance-data-start) word-shift) + instance-pointer-lowtag) info)) (inst and :dword r10-tn (fixnumize (1- (ash 1 (* info-number-bits 2))))) (inst cmp :dword r10-tn (fixnumize (1+ (ash +fdefn-info-num+ info-number-bits)))) (inst jmp :b undefined) - (loadw length vector 1 other-pointer-lowtag) - (inst mov fun (ea (- 8 other-pointer-lowtag) vector length - (ash 1 (- word-shift n-fixnum-tag-bits)))) + ;; Read the logical instance length, i.e. excluding a stable hash slot if present, + ;; but including a LAYOUT slot if #-compact-instance-header. + ;; There's a optimization possibility here to eliminate one SHR, which would use + ;; a 4-byte unaligned load at byte index 1 of the header, which would put the length + ;; in byte index 0 of the register, but over by 2 bits; mask that, adjust the EA SCALE + ;; to get the indexing right. That's too abstraction-violating for my taste. + (load-instance-length length info nil) + ;; After this MOV, the FUN register will hold the FDEFN. + (inst mov fun (ea (- instance-pointer-lowtag) info length n-word-bytes)) (inst jmp (ea (- (* fdefn-raw-addr-slot n-word-bytes) other-pointer-lowtag) fun)) UNDEFINED @@ -268,9 +279,10 @@ ((:arg target (descriptor-reg any-reg) rdx-offset) (:arg start any-reg rbx-offset) (:arg count any-reg rcx-offset) + (:temp bsp-temp any-reg r11-offset) (:temp catch any-reg rax-offset)) - (declare (ignore start count)) + (declare (ignore start count bsp-temp)) (load-tl-symbol-value catch *current-catch-block*) @@ -323,6 +335,7 @@ (:temp where unsigned-reg r8-offset) (:temp symbol unsigned-reg r9-offset) (:temp value unsigned-reg r10-offset) + (:temp bsp-temp unsigned-reg r11-offset) (:temp zero complex-double-reg float0-offset)) AGAIN (let ((error (generate-error-code nil 'invalid-unwind-error))) @@ -349,7 +362,7 @@ ;; run it twice) one of the variables being unbound can be ;; *interrupts-enabled* (loadw where uwp unwind-block-bsp-slot) - (unbind-to-here where symbol value temp-reg-tn zero) + (unbind-to-here where symbol value bsp-temp zero) ;; Set next unwind protect context. (loadw block uwp unwind-block-uwp-slot) @@ -370,7 +383,7 @@ DO-EXIT (loadw where block unwind-block-bsp-slot) - (unbind-to-here where symbol value temp-reg-tn zero) + (unbind-to-here where symbol value bsp-temp zero) (loadw rbp-tn block unwind-block-cfp-slot) @@ -388,99 +401,55 @@ ;; to stack, because we do do not give the register allocator access to it. ;; And call_into_lisp saves it as per convention, not that it matters, ;; because there's no way to get back into C code anyhow. - (inst mov thread-base-tn (ea (make-fixup "all_threads" :foreign-dataref))) - (inst mov thread-base-tn (ea thread-base-tn)))) + (inst mov thread-tn (ea (make-fixup "all_threads" :foreign-dataref))) + (inst mov thread-tn (ea thread-tn)))) -;;; Perform a store to code, updating the GC page (card) protection bits. -;;; This is not a "good" implementation of soft card marking. -;;; It is used *only* for pages of code. The real implementation (work in -;;; progress) will differ in at least these ways: -;;; - there will be no use of pseudo-atomic -;;; - stores will be inlined without the helper routine below -;;; - will be insensitive to the size of a page table entry -;;; - will avoid use of a :lock prefix by allocating 1 byte per mark -;;; - won't need to subtract the heap base or compare to the card count -;;; to compute the mark address, so will use fewer instructions. -;;; It is similar in that for code objects (indeed most objects -;;; except simple-vectors), it marks the object header which is -;;; not always on the same GC card affected by the store operation -;;; +;;; Perform a store to code, updating the GC card mark bit. +;;; This has two additional complications beyond the ordinary +;;; generational barrier: +;;; 1. immobile code uses its own card table which maps linearly +;;; with the page index, unlike the dynamic space card table +;;; that has a different way of computing a card address. +;;; 2. code objects are so seldom written that it behooves us to +;;; track within each object whether it has been written, +;;; thereby avoiding scanning of unwritten objects. +;;; This is especially important for immobile space where +;;; it is likely that new code will be co-located on a page +;;; with old code due to the non-moving allocator. #+sb-assembling (define-assembly-routine (code-header-set (:return-style :none)) () - (inst push rax-tn) - (inst push rdi-tn) - ;; stack: spill[2], ret-pc, object, index, value-to-store - + ;; stack: ret-pc, object, index, value-to-store + (symbol-macrolet ((object (ea 8 rsp-tn)) + (word-index (ea 16 rsp-tn)) + (newval (ea 24 rsp-tn)) + ;; these are declared as vop temporaries + (rax rax-tn) + (rdx rdx-tn) + (rdi rdi-tn)) (ensure-thread-base-tn-loaded) (pseudo-atomic () (assemble () #+immobile-space (progn - (inst mov temp-reg-tn (ea 24 rsp-tn)) - (inst sub temp-reg-tn (thread-slot-ea thread-varyobj-space-addr-slot)) - (inst shr temp-reg-tn (1- (integer-length immobile-card-bytes))) - (inst cmp temp-reg-tn (thread-slot-ea thread-varyobj-card-count-slot)) + (inst mov rax object) + (inst sub rax (thread-slot-ea thread-varyobj-space-addr-slot)) + (inst shr rax (1- (integer-length immobile-card-bytes))) + (inst cmp rax (thread-slot-ea thread-varyobj-card-count-slot)) (inst jmp :ae try-dynamic-space) - (inst mov rdi-tn (thread-slot-ea thread-varyobj-card-marks-slot)) - (inst bts :dword :lock (ea rdi-tn) temp-reg-tn) + (inst mov rdi (thread-slot-ea thread-varyobj-card-marks-slot)) + (inst bts :dword :lock (ea rdi-tn) rax) (inst jmp store)) - TRY-DYNAMIC-SPACE - (inst mov temp-reg-tn (ea 24 rsp-tn)) ; reload - (inst sub temp-reg-tn (thread-slot-ea thread-dynspace-addr-slot)) - (inst shr temp-reg-tn (1- (integer-length gencgc-card-bytes))) - (inst cmp temp-reg-tn (thread-slot-ea thread-dynspace-card-count-slot)) - (inst jmp :ae store) ; neither dynamic nor immobile space. (weird!) - - ;; sizeof (struct page) depends on GENCGC-CARD-BYTES - ;; It's 4+2+1+1 = 8 bytes if GENCGC-CARD-BYTES is (unsigned-byte 16), - ;; or 4+4+1+1 = 10 bytes (rounded to 12) if wider than (unsigned-byte 16). - ;; See the corresponding alien structure definition in 'room.lisp' - (cond ((typep gencgc-card-bytes '(unsigned-byte 16)) - (inst shl temp-reg-tn 3) ; multiply by 8 - (inst add temp-reg-tn (thread-slot-ea thread-dynspace-pte-base-slot)) - ;; clear WP - bit index 5 of flags byte - (inst and :byte :lock (ea 6 temp-reg-tn) (lognot (ash 1 5)))) - (t - (inst lea temp-reg-tn (ea temp-reg-tn temp-reg-tn 2)) ; multiply by 3 - (inst shl temp-reg-tn 2) ; then by 4, = 12 - (inst add temp-reg-tn (thread-slot-ea thread-dynspace-pte-base-slot)) - ;; clear WP - (inst and :byte :lock (ea 8 temp-reg-tn) (lognot (ash 1 5))))) - + (inst mov rax object) + (inst shr rax gencgc-card-shift) + (inst and :dword rax card-index-mask) + (inst mov :byte (ea gc-card-table-reg-tn rax) 0) STORE - (inst mov rdi-tn (ea 24 rsp-tn)) ; object - (inst mov temp-reg-tn (ea 32 rsp-tn)) ; word index - (inst mov rax-tn (ea 40 rsp-tn)) ; newval + (inst mov rdi object) + (inst mov rdx word-index) + (inst mov rax newval) ;; set 'written' flag in the code header - (inst or :byte :lock (ea (- 3 other-pointer-lowtag) rdi-tn) #x40) + (inst or :byte :lock (ea (- 3 other-pointer-lowtag) rdi) #x40) ;; store newval into object - (inst mov (ea (- other-pointer-lowtag) rdi-tn temp-reg-tn n-word-bytes) - rax-tn))) - (inst pop rdi-tn) ; restore - (inst pop rax-tn) + (inst mov (ea (- other-pointer-lowtag) rdi rdx n-word-bytes) rax)))) (inst ret 24)) ; remove 3 stack args - -;;; Currently the only objects for which it is necessary to call TOUCH-GC-CARD -;;; are those on varyobj pages. Therefore if no immobile-space feature, skip it. -;;; This is not the situation for pages of code, where we manually toggle dynamic space -;;; card marks so that when recording code coverage we don't incur the cost of a kernel -;;; signal on a page that was otherwise untouched. -#+sb-assembling -(define-assembly-routine (touch-gc-card (:return-style :none)) () - ;; stack: ret-pc, object - #+immobile-space - (progn - (ensure-thread-base-tn-loaded) - (inst mov temp-reg-tn (ea 8 rsp-tn)) - (inst sub temp-reg-tn (thread-slot-ea thread-varyobj-space-addr-slot)) - (inst shr temp-reg-tn (integer-length (1- immobile-card-bytes))) - (inst cmp temp-reg-tn (thread-slot-ea thread-varyobj-card-count-slot)) - (inst jmp :ae DONE) - - (inst push rax-tn) - (inst mov rax-tn (thread-slot-ea thread-varyobj-card-marks-slot)) - (inst bts :dword :lock (ea rax-tn) temp-reg-tn) - (inst pop rax-tn)) - DONE - (inst ret 8)) ; remove 1 stack arg diff -Nru sbcl-2.1.1/src/assembly/x86-64/support.lisp sbcl-2.1.11/src/assembly/x86-64/support.lisp --- sbcl-2.1.1/src/assembly/x86-64/support.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/support.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,11 +14,24 @@ (floor (+ feature-bit n-fixnum-tag-bits) n-byte-bits) (inst test :byte (static-symbol-value-ea '*cpu-feature-bits* byte) (ash 1 bit)))) -(defun invoke-asm-routine (inst routine vop) +(defun uniquify-fixup (name &aux (asmstream *asmstream*)) + (or (cdr (assoc name (sb-assem::asmstream-indirection-table asmstream))) + (let ((label (gen-label))) + ;; This has to be separate from the :ELSEWHERE section because we could be + ;; emitting code into :ELSEWHERE when requesting a unique label. + (assemble (:indirections) + (emit-label label) + (inst jmp (ea (make-fixup name :assembly-routine*)))) + (push (cons name label) (sb-assem::asmstream-indirection-table asmstream)) + label))) + +(defun invoke-asm-routine (inst routine vop &optional uniquify) (declare (ignorable vop)) (let ((fixup (cond ((sb-c::code-immobile-p vop) (make-fixup routine :assembly-routine)) + (uniquify + (uniquify-fixup routine)) (t (ea (make-fixup routine :assembly-routine*)))))) (ecase inst @@ -54,27 +67,18 @@ (inst ret))) ((:none :full-call-no-return)))) -(defmacro with-registers-preserved ((convention fpr-size &key except) &body body) +(defmacro with-registers-preserved ((convention &key except) &body body) ;: Convention: ;; C = save GPRs that C call can change ;; Lisp = save GPRs that lisp call can change - (multiple-value-bind (mnemonic fpr-align getter) - (ecase fpr-size - (xmm (values 'movaps 16 'sb-x86-64-asm::get-fpr)) - (ymm (values 'vmovaps 32 'sb-x86-64-asm::get-avx2))) - (flet ((fpr-save/restore (operation) - (loop for regno below 16 - collect - (ecase operation - (push - `(inst ,mnemonic (ea ,(* regno fpr-align) rsp-tn) (,getter ,regno))) - (pop - `(inst ,mnemonic (,getter ,regno) (ea ,(* regno fpr-align) rsp-tn)))))) - (gpr-save/restore (operation except) + (let ((fpr-align 32)) + (flet ((gpr-save/restore (operation except) (declare (type (member push pop) operation)) (let ((registers (ecase convention + ;; RBX and R12..R15 are preserved across C call (c '#1=(rax-tn rcx-tn rdx-tn rsi-tn rdi-tn r8-tn r9-tn r10-tn r11-tn)) - (lisp '(rbx-tn r12-tn r14-tn r15-tn . #1#))))) + ;; all GPRs are potentially destroyed across lisp call + (lisp '(rbx-tn r12-tn #-sb-thread r13-tn r14-tn r15-tn . #1#))))) (when except (setf registers (remove except registers))) ;; Preserve alignment @@ -88,10 +92,26 @@ (inst mov rbp-tn rsp-tn) (inst and rsp-tn ,(- fpr-align)) (inst sub rsp-tn ,(* 16 fpr-align)) - ,@(fpr-save/restore 'push) + ;; Using rip-relative call indirect makes shrinkwrapped cores work + ;; with no modification whatsoever to editcore. + ;; It wouldn't work straightforwardly using a call indirect + ;; with an absolute EA. + ;; KLUDGE: index of FPR-SAVE is 4 + ;; (inst call (ea (make-fixup 'fpr-save :assembly-routine*))) + (inst call (ea (make-fixup nil :code-object + (+ (ash code-constants-offset word-shift) + (* 4 sb-vm:n-word-bytes) + (- other-pointer-lowtag))) + rip-tn)) ,@(gpr-save/restore 'push except) ,@body ,@(gpr-save/restore 'pop except) - ,@(fpr-save/restore 'pop) + ;; KLUDGE: index of FPR-RESTORE is 6 + ;; (inst call (ea (make-fixup 'fpr-restore :assembly-routine*))) + (inst call (ea (make-fixup nil :code-object + (+ (ash code-constants-offset word-shift) + (* 6 sb-vm:n-word-bytes) + (- other-pointer-lowtag))) + rip-tn)) (inst mov rsp-tn rbp-tn) (inst pop rbp-tn))))) diff -Nru sbcl-2.1.1/src/assembly/x86-64/tramps.lisp sbcl-2.1.11/src/assembly/x86-64/tramps.lisp --- sbcl-2.1.1/src/assembly/x86-64/tramps.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/assembly/x86-64/tramps.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -5,68 +5,54 @@ (in-package "SB-VM") -;;; It is arbitrary whether each of the next 4 routines is named ALLOC-something, -;;; exporting an additional entry named CONS-something, versus being named CONS-something -;;; and exporting ALLOC-something. It just depends on which of those you would like -;;; to have to set and clear the low bit to match ALLOC-DISPATCH. -;;; Think of "cons" as meaning the generic sense of "consing", not as actually -;;; allocating conses, because fixed-sized non-cons object allocation may enter -;;; through the cons entry point. Cons cells *must* use that entry point. -(define-assembly-routine (alloc->rnn (:export cons->rnn)) () - (inst or :byte (ea 8 rsp-tn) 1) - CONS->RNN - (with-registers-preserved (c xmm) - (inst mov rdi-tn (ea 16 rbp-tn)) - (inst call (make-fixup 'alloc-dispatch :assembly-routine)) - (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack +(macrolet ((do-fprs (operation regset) + (multiple-value-bind (mnemonic fpr-align) + (ecase regset + (:xmm (values 'movaps 16)) + (:ymm (values 'vmovaps 32))) + `(progn + ,@(loop for regno below 16 + collect + (ecase operation + (push + `(inst ,mnemonic (ea ,(+ 8 (* regno fpr-align)) rsp-tn) + (sb-x86-64-asm::get-fpr ,regset ,regno))) + (pop + `(inst ,mnemonic (sb-x86-64-asm::get-fpr ,regset ,regno) + (ea ,(+ 8 (* regno fpr-align)) rsp-tn))))))))) + ;; Caller will have allocated 512 bytes above the stack-pointer + ;; prior to the CALL. Use that as the save area. + (define-assembly-routine (save-ymm) () (do-fprs push :ymm)) + (define-assembly-routine (restore-ymm) () (do-fprs pop :ymm)) + ;; As above, but only 256 bytes of the save area are needed, the rest goes to waste. + (define-assembly-routine (save-xmm (:export fpr-save)) () + fpr-save ; KLUDGE: this is element 4 of the entry point vector + (do-fprs push :xmm)) + (define-assembly-routine (restore-xmm (:export fpr-restore)) () + fpr-restore ; KLUDGE: this is element 6 of the entry point vector + (do-fprs pop :xmm))) -#+avx2 -(define-assembly-routine (alloc->rnn.avx2 (:export cons->rnn.avx2)) () - (inst or :byte (ea 8 rsp-tn) 1) - CONS->RNN.AVX2 - (with-registers-preserved (c ymm) +(define-assembly-routine (alloc-tramp) () + (with-registers-preserved (c) (inst mov rdi-tn (ea 16 rbp-tn)) - (inst call (make-fixup 'alloc-dispatch :assembly-routine)) + (inst call (make-fixup "alloc" :foreign)) (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack -(define-assembly-routine (alloc->r11 (:export cons->r11) (:return-style :none)) () - (inst or :byte (ea 8 rsp-tn) 1) - CONS->R11 - (with-registers-preserved (c xmm :except r11-tn) - (inst mov rdi-tn (ea 16 rbp-tn)) - (inst call (make-fixup 'alloc-dispatch :assembly-routine)) - (inst mov r11-tn rax-tn)) - (inst ret 8)) ; pop argument - -#+avx2 -(define-assembly-routine (alloc->r11.avx2 (:export cons->r11.avx2) (:return-style :none)) () - (inst or :byte (ea 8 rsp-tn) 1) - CONS->R11.AVX2 - (with-registers-preserved (c ymm :except r11-tn) +(define-assembly-routine (list-alloc-tramp) () + (with-registers-preserved (c) (inst mov rdi-tn (ea 16 rbp-tn)) - (inst call (make-fixup 'alloc-dispatch :assembly-routine)) - (inst mov r11-tn rax-tn)) - (inst ret 8)) ; pop argument - -(define-assembly-routine (alloc-dispatch (:return-style :none)) () - ;; If RDI has a 0 in the low bit, then we're allocating cons cells. - ;; A 1 bit signifies anything other than cons cells, and is equivalent - ;; to "could this object consume large-object pages" in gencgc. - (inst test :byte rdi-tn 1) - (inst jmp :z (make-fixup "alloc_list" :foreign)) - (inst xor :byte rdi-tn 1) ; clear the bit - (inst jmp (make-fixup "alloc" :foreign))) + (inst call (make-fixup "alloc_list" :foreign)) + (inst mov (ea 16 rbp-tn) rax-tn))) ; result onto stack ;;; These routines are for the deterministic consing profiler. ;;; The C support routine's argument is the return PC. -;;; FIXME: we're missing routines that preserve YMM. I guess nobody cares. (define-assembly-routine (enable-alloc-counter) () - (with-registers-preserved (c xmm) + (with-registers-preserved (c) (inst lea rdi-tn (ea 8 rbp-tn)) (pseudo-atomic () (inst call (make-fixup "allocation_tracker_counted" :foreign))))) (define-assembly-routine (enable-sized-alloc-counter) () - (with-registers-preserved (c xmm) + (with-registers-preserved (c) (inst lea rdi-tn (ea 8 rbp-tn)) (pseudo-atomic () (inst call (make-fixup "allocation_tracker_sized" :foreign))))) @@ -77,6 +63,13 @@ (inst push (ea n-word-bytes rbp-tn)) (inst jmp (ea (- (* closure-fun-slot n-word-bytes) fun-pointer-lowtag) rax))) +#+win32 +(define-assembly-routine + (undefined-alien-tramp (:return-style :none)) + () + (error-call nil 'undefined-alien-fun-error rbx-tn)) + +#-win32 (define-assembly-routine (undefined-alien-tramp (:return-style :none)) () @@ -128,17 +121,7 @@ (inst jmp (object-slot-ea rax-tn closure-fun-slot fun-pointer-lowtag))) (define-assembly-routine (ensure-symbol-hash (:return-style :raw)) () - #+avx2 - (progn - (test-cpu-feature cpu-has-ymm-registers) - (inst jmp :z call-preserving-xmm-only) - (with-registers-preserved (lisp ymm :except r11-tn) - (inst mov rdx-tn (ea 16 rbp-tn)) ; arg - (call-static-fun 'ensure-symbol-hash 1) - (inst mov (ea 16 rbp-tn) rdx-tn)) ; result to arg passing loc - (inst ret)) - call-preserving-xmm-only - (with-registers-preserved (lisp xmm :except r11-tn) + (with-registers-preserved (lisp) (inst mov rdx-tn (ea 16 rbp-tn)) ; arg (call-static-fun 'ensure-symbol-hash 1) (inst mov (ea 16 rbp-tn) rdx-tn))) ; result to arg passing loc @@ -146,33 +129,13 @@ (define-assembly-routine (sb-impl::install-hash-table-lock (:return-style :raw)) () - #+avx2 - (progn - (test-cpu-feature cpu-has-ymm-registers) - (inst jmp :z call-preserving-xmm-only) - (with-registers-preserved (lisp ymm :except r11-tn) - (inst mov rdx-tn (ea 16 rbp-tn)) ; arg - (call-static-fun 'sb-impl::install-hash-table-lock 1) - (inst mov (ea 16 rbp-tn) rdx-tn)) ; result to arg passing loc - (inst ret)) - call-preserving-xmm-only - (with-registers-preserved (lisp xmm :except r11-tn) + (with-registers-preserved (lisp) (inst mov rdx-tn (ea 16 rbp-tn)) ; arg (call-static-fun 'sb-impl::install-hash-table-lock 1) (inst mov (ea 16 rbp-tn) rdx-tn))) ; result to arg passing loc (define-assembly-routine (invalid-layout-trap (:return-style :none)) () - #+avx2 - (progn - (test-cpu-feature cpu-has-ymm-registers) - (inst jmp :z call-preserving-xmm-only) - (with-registers-preserved (lisp ymm :except r11-tn) - (inst mov rdx-tn (ea 16 rbp-tn)) ; arg - (call-static-fun 'update-object-layout 1) - (inst mov (ea 16 rbp-tn) rdx-tn)) ; result to arg passing loc - (inst ret)) ; Caller pops the result - call-preserving-xmm-only - (with-registers-preserved (lisp xmm :except r11-tn) + (with-registers-preserved (lisp) (inst mov rdx-tn (ea 16 rbp-tn)) ; arg (call-static-fun 'update-object-layout 1) (inst mov (ea 16 rbp-tn) rdx-tn)) ; result to arg passing loc diff -Nru sbcl-2.1.1/src/code/alien-callback.lisp sbcl-2.1.11/src/code/alien-callback.lisp --- sbcl-2.1.1/src/code/alien-callback.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/alien-callback.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,11 +12,16 @@ (in-package "SB-ALIEN") -;;; ALIEN-CALLBACK is supposed to be external in SB-ALIEN-INTERNALS, but the -;;; export gets lost, and then 'chill' gets a conflict with SB-ALIEN over it. +;;; ALIEN-CALLBACK is supposed to be external in SB-ALIEN-INTERNALS, +;;; but the export gets lost (as this is now a warm-loaded file), and +;;; then 'chill' gets a conflict with SB-ALIEN over it. (eval-when (:compile-toplevel :load-toplevel :execute) (export (intern "ALIEN-CALLBACK" "SB-ALIEN-INTERNALS") - "SB-ALIEN-INTERNALS")) + "SB-ALIEN-INTERNALS") + (export (intern "DEFINE-ALIEN-CALLABLE" "SB-ALIEN") + "SB-ALIEN") + (export (intern "ALIEN-CALLABLE-FUNCTION" "SB-ALIEN") + "SB-ALIEN")) ;;;; ALIEN CALLBACKS ;;;; @@ -250,7 +255,7 @@ (defun invalidate-alien-callback (alien) "Invalidates the callback designated by the alien, if any, allowing the associated lisp function to be GC'd, and causing further calls to the same -callback signal an error." +callback to signal an error." (let ((info (alien-callback-info alien))) (when (and info (callback-info-function info)) ;; sap cache @@ -288,6 +293,49 @@ (defun ,name ,lambda-list ,@forms) (defparameter ,name (alien-callback ,specifier #',name))))) +;;;; Alien callables + +(define-load-time-global *alien-callables* (make-hash-table :test #'eq) + "Map from Lisp symbols to the alien callable functions they name.") + +(defmacro define-alien-callable (name result-type typed-lambda-list &body body) + "Define an alien callable function in the alien callable namespace with result +type RESULT-TYPE and with lambda list specifying the alien types of the +arguments." + (multiple-value-bind (lisp-name alien-name) + (pick-lisp-and-alien-names name) + (declare (ignore alien-name)) + `(progn + (invalidate-alien-callable ',lisp-name) + (setf (gethash ',lisp-name *alien-callables*) + (alien-lambda ,result-type ,typed-lambda-list ,@body))))) + +(defun alien-callable-function (name) + "Return the alien callable function associated with NAME." + (gethash name *alien-callables*)) + +(defun invalidate-alien-callable (name) + "Invalidates the callable designated by the alien, if any, allowing the +associated lisp function to be GC'd, and causing further calls to the same +callable to signal an error." + (multiple-value-bind (lisp-name alien-name) + (pick-lisp-and-alien-names name) + (declare (ignore alien-name)) + (let ((alien (alien-callable-function lisp-name))) + (when alien + (invalidate-alien-callback alien))) + (remhash lisp-name *alien-callables*))) + +(defun initialize-alien-callable-symbol (name) + "Initialize the alien symbol named by NAME with its alien callable +function value." + (multiple-value-bind (lisp-name alien-name) + (pick-lisp-and-alien-names name) + (setf (%alien-value (foreign-symbol-sap alien-name t) + 0 + (make-alien-pointer-type)) + (cast (alien-callable-function lisp-name) (* t))))) + (in-package "SB-THREAD") #+sb-thread (defun enter-foreign-callback (index return arguments) diff -Nru sbcl-2.1.1/src/code/alieneval.lisp sbcl-2.1.11/src/code/alieneval.lisp --- sbcl-2.1.1/src/code/alieneval.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/alieneval.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -172,6 +172,17 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (create-alien-type-class-if-necessary 'root 'alien-type nil)) +(def!struct (alien-type + (:copier nil) + (:constructor make-alien-type + (&key class bits alignment + &aux (alignment + (or alignment (guess-alignment bits)))))) + (class 'root :type symbol :read-only t) + (bits nil :type (or null unsigned-byte)) + (alignment nil :type (or null unsigned-byte))) +(!set-load-form-method alien-type (:xc :target)) + (defmethod print-object ((type alien-type) stream) (print-unreadable-object (type stream :type t) (sb-impl:print-type-specifier stream (unparse-alien-type type)))) @@ -519,7 +530,7 @@ ;; the register uninitialized. On those platforms, we use an ;; alien-rep of the full register width when checking for purposes ;; of return values and override the naturalize method to perform - ;; the sign extension (in compiler/target/c-call.lisp). + ;; the sign extension (in compiler/{arch}/c-call.lisp). (ecase context ((:normal #-(or x86 x86-64) :result) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) @@ -541,20 +552,23 @@ (declare (ignore type)) value) +(defun alien-integer->sap-ref-fun (signed bits) + (if signed + (case bits + (8 'signed-sap-ref-8) + (16 'signed-sap-ref-16) + (32 'signed-sap-ref-32) + (64 'signed-sap-ref-64)) + (case bits + (8 'sap-ref-8) + (16 'sap-ref-16) + (32 'sap-ref-32) + (64 'sap-ref-64)))) + (define-alien-type-method (integer :extract-gen) (type sap offset) (declare (type alien-integer-type type)) - (let ((ref-fun - (if (alien-integer-type-signed type) - (case (alien-integer-type-bits type) - (8 'signed-sap-ref-8) - (16 'signed-sap-ref-16) - (32 'signed-sap-ref-32) - (64 'signed-sap-ref-64)) - (case (alien-integer-type-bits type) - (8 'sap-ref-8) - (16 'sap-ref-16) - (32 'sap-ref-32) - (64 'sap-ref-64))))) + (let ((ref-fun (alien-integer->sap-ref-fun (alien-integer-type-signed type) + (alien-integer-type-bits type)))) (if ref-fun `(,ref-fun ,sap (/ ,offset sb-vm:n-byte-bits)) (error "cannot extract ~W-bit integers" @@ -1135,7 +1149,7 @@ (arg-types (missing-arg) :type list) ;; The 3rd-party CFFI library uses presence of &REST in an argument list ;; as indicative of "..." in the C prototype. We can record that too. - (varargs nil :type (or boolean (eql :unspecified))) + (varargs nil :type (or boolean fixnum (eql :unspecified))) (stub nil :type (or null function)) (convention nil :type calling-convention)) ;;; The safe default is to assume that everything is varargs. @@ -1153,6 +1167,7 @@ ;;; result-type in this case. If convention is ever to become a part ;;; of result-type, such a syntax can be retained. + (define-alien-type-translator function (result-type &rest arg-types &environment env) (binding* (((bare-result-type calling-convention) @@ -1160,14 +1175,21 @@ ((cons calling-convention *) (values (second result-type) (first result-type))) (t result-type))) - (varargs (eq (car (last arg-types)) '&rest))) + (varargs (or (eq (car (last arg-types)) '&rest) + (position '&optional arg-types))) + (arg-types (if (integerp varargs) + (remove '&optional arg-types) + arg-types))) (make-alien-fun-type :convention calling-convention :result-type (let ((*values-type-okay* t)) (parse-alien-type bare-result-type env)) :varargs (or varargs *alien-fun-type-varargs-default*) - :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env)) - (if varargs (butlast arg-types) arg-types))))) + :arg-types (mapcar (lambda (arg-type) + (parse-alien-type arg-type env)) + (if (eql varargs t) + (butlast arg-types) + arg-types))))) (define-alien-type-method (fun :unparse) (type) `(function ,(let ((result-type @@ -1267,6 +1289,29 @@ (local-alien-info-force-to-memory-p info) (unparse-alien-type (local-alien-info-type info))))) +(defun cas-alien (symbol old new) + (let ((info (info :variable :alien-info symbol))) + (when info + (let ((type (heap-alien-info-type info))) + (when (and (typep type 'alien-integer-type) + (eq (alien-integer-type-class type) 'integer) + (member (alien-integer-type-bits type) + '(8 16 32 #+64-bit 64))) + (let ((signed (alien-integer-type-signed type)) + (bits (alien-integer-type-bits type)) + (sap-form `(foreign-symbol-sap ,(heap-alien-info-alien-name info) t))) + (cond ((and signed (< bits sb-vm:n-word-bits)) + (let ((mask (1- (ash 1 bits)))) + `(sb-vm::sign-extend + (funcall #'(cas ,(alien-integer->sap-ref-fun nil bits)) + (logand (the (signed-byte ,bits) ,old) ,mask) + (logand (the (signed-byte ,bits) ,new) ,mask) + ,sap-form 0) + ,bits))) + (t + `(funcall #'(cas ,(alien-integer->sap-ref-fun signed bits)) + ,old ,new ,sap-form 0))))))))) + (in-package "SB-IMPL") (defun extern-alien-name (name) diff -Nru sbcl-2.1.1/src/code/alien-type.lisp sbcl-2.1.11/src/code/alien-type.lisp --- sbcl-2.1.1/src/code/alien-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/alien-type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,57 +13,13 @@ (in-package "SB-KERNEL") -(/show0 "code/alien-type.lisp 16") - (sb-xc:defstruct (alien-value (:copier nil) (:constructor %sap-alien (sap type))) (sap nil :type sb-sys:system-area-pointer) (type nil :type sb-alien::alien-type)) -(sb-xc:proclaim '(freeze-type alien-value)) - -(!begin-collecting-cold-init-forms) - -(define-type-class alien :enumerable nil :might-contain-other-types nil) - -(define-type-method (alien :negate) (type) (make-negation-type type)) - -(define-type-method (alien :unparse) (type) - `(alien ,(unparse-alien-type (alien-type-type-alien-type type)))) - -(define-type-method (alien :simple-subtypep) (type1 type2) - (values (alien-subtype-p (alien-type-type-alien-type type1) - (alien-type-type-alien-type type2)) - t)) +(proclaim '(freeze-type alien-value)) ;;; KLUDGE: This !DEFINE-SUPERCLASSES gets executed much later than the ;;; others (toplevel form time instead of cold load init time) because ;;; ALIEN-VALUE itself is a structure which isn't defined until fairly ;;; late. (!define-superclasses alien ((alien-value)) progn) - -(define-type-method (alien :simple-=) (type1 type2) - (let ((alien-type-1 (alien-type-type-alien-type type1)) - (alien-type-2 (alien-type-type-alien-type type2))) - (values (or (eq alien-type-1 alien-type-2) - (alien-type-= alien-type-1 alien-type-2)) - t))) - -(def-type-translator alien (&optional (alien-type nil)) - (typecase alien-type - (null - (make-alien-type-type)) - (alien-type - (make-alien-type-type alien-type)) - (t - (make-alien-type-type (parse-alien-type alien-type (make-null-lexenv)))))) - -(defun make-alien-type-type (&optional alien-type) - (if alien-type - (let ((lisp-rep-type (compute-lisp-rep-type alien-type))) - (if lisp-rep-type - (single-value-specifier-type lisp-rep-type) - (%make-alien-type-type alien-type))) - *universal-type*)) - -(!defun-from-collected-cold-init-forms !alien-type-cold-init) - -(/show0 "code/alien-type.lisp end of file") diff -Nru sbcl-2.1.1/src/code/alloc.lisp sbcl-2.1.11/src/code/alloc.lisp --- sbcl-2.1.1/src/code/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -21,38 +21,57 @@ (addr system-area-pointer) (bytes unsigned)) -(!define-load-time-global *allocator-mutex* (sb-thread:make-mutex :name "Allocator")) +(define-load-time-global *allocator-mutex* (sb-thread:make-mutex :name "Allocator")) (defun allocate-static-vector (widetag length words) (declare (type (unsigned-byte #.n-widetag-bits) widetag) (type word words) (type index length)) - ;; This does not need WITHOUT-GCING, but it will be implicitly wrapped - ;; in WITHOUT-INTERRUPTS due to the default behavior of system mutexes, - ;; which is important so that we don't leave an inconsistent state. - ;; To think about why it is OK to leave GC enabled, consider that - ;; neither GC nor another thread will examine static space above the - ;; current value of *STATIC-SPACE-FREE-POINTER*. - (or (with-system-mutex (*allocator-mutex*) - (let* ((pointer *static-space-free-pointer*) - (nbytes (pad-data-block (+ words vector-data-offset))) - (new-pointer (sap+ pointer nbytes))) - (when (sap<= new-pointer (int-sap static-space-end)) + ;; Static space starts out zeroed, so it looks a bunch of cons cells + ;; containing (0 . 0) above the free pointer. Therefore bumping the pointer + ;; merely exposes a new range of cons cells, if GC should happen to run + ;; while executing this code. And because we assign the LENGTH of the vector + ;; prior to setting the widetag, and LENGTH is a fixnum, then at worst + ;; someone can transiently observe a cons of (0 . a-fixnum). + (let* ((nbytes (pad-data-block (+ words vector-data-offset))) + (pointer (alien-funcall (extern-alien "atomic_bump_static_space_free_ptr" + (function system-area-pointer int)) + nbytes))) + (if (/= (sap-int pointer) 0) ;; By storing the length prior to the widetag, the word at the old ;; free pointer decodes as a cons instead of a 0-length vector. ;; Not that it should matter, but it seems slightly better to change ;; the new object atomically to a correctly-sized vector rather than ;; a cons changing into the wrong vector into the right vector. - (setf (sap-ref-word pointer (ash vector-length-slot word-shift)) - (fixnumize length)) + (let ((v (%make-lisp-obj (sap-int (sap+ pointer other-pointer-lowtag))))) + (setf (%array-fill-pointer v) length ;; then store the widetag - (setf (sap-ref-word pointer 0) widetag) - ;; then the new free pointer - (setf *static-space-free-pointer* new-pointer) + (sap-ref-8 pointer #+big-endian (1- sb-vm:n-word-bytes) + #+little-endian 0) + widetag) + v) + (error 'simple-storage-condition + :format-control + "Not enough room left in static space to allocate vector.")))) + +#+darwin-jit +(defun allocate-static-code-vector (widetag length words) + (declare (type (unsigned-byte #.n-widetag-bits) widetag) + (type word words) + (type index length)) + (or (with-system-mutex (*allocator-mutex*) + (let* ((pointer *static-code-space-free-pointer*) + (nbytes (pad-data-block (+ words vector-data-offset))) + (new-pointer (sap+ pointer nbytes))) + (when (sap<= new-pointer (int-sap static-code-space-end)) + (setf (sap-ref-word-jit pointer (ash vector-length-slot word-shift)) + (fixnumize length)) + (setf (sap-ref-word-jit pointer 0) widetag) + (setf *static-code-space-free-pointer* new-pointer) (%make-lisp-obj (logior (sap-int pointer) other-pointer-lowtag))))) (error 'simple-storage-condition :format-control - "Not enough room left in static space to allocate vector."))) + "Not enough room left in static code space to allocate vector."))) #+immobile-space (progn @@ -81,7 +100,7 @@ ;;; A better structure would be just a sorted array of sizes ;;; with each entry pointing to the holes which are threaded through ;;; some bytes in the storage itself rather than through cons cells. -(!define-load-time-global *immobile-freelist* nil) +(define-load-time-global *immobile-freelist* nil) ;;; Return the zero-based index within the varyobj subspace of immobile space. (defun varyobj-page-index (address) @@ -205,10 +224,10 @@ (let ((n-trailing-bytes (- (nth-value 1 (ceiling free-ptr immobile-card-bytes))))) (setf (sap-ref-word (int-sap free-ptr) 0) simple-array-fixnum-widetag - (sap-ref-word (int-sap free-ptr) n-word-bytes) + (%array-fill-pointer + (%make-lisp-obj (logior free-ptr sb-vm:other-pointer-lowtag))) ;; Convert bytes to words, subtract the header and vector length. - (ash (- (ash n-trailing-bytes (- word-shift)) 2) - n-fixnum-tag-bits))))) + (- (ash n-trailing-bytes (- word-shift)) 2))))) (defun unallocate (hole) #+immobile-space-debug @@ -359,9 +378,8 @@ (setf (sap-ref-word (int-sap addr) 0) word0 (sap-ref-word (int-sap addr) n-word-bytes) word1) ;; 0-fill the remainder of the object - (#+64-bit system-area-ub64-fill - #-64-bit system-area-ub32-fill - 0 (int-sap addr) 2 (- (ash n-bytes (- word-shift)) 2)) + (alien-funcall (extern-alien "memset" (function void system-area-pointer int unsigned)) + (sap+ (int-sap addr) (* 2 n-word-bytes)) 0 (- n-bytes (* 2 n-word-bytes))) ;; Only after making the new object can we reduce the size of the hole ;; that contained the new allocation (if it entailed chopping a hole ;; into parts). In this way, heap scans do not read junk. @@ -394,13 +412,14 @@ (#.symbol-widetag 1) (#.fdefn-widetag 2) (#.instance-widetag - (cond ((<= aligned-nwords 16) (setq aligned-nwords 16) 3) - ((<= aligned-nwords 24) (setq aligned-nwords 24) 4) - ((<= aligned-nwords 32) (setq aligned-nwords 32) 5) - ((<= aligned-nwords 48) (setq aligned-nwords 48) 6) + (cond ((<= aligned-nwords 8) (setq aligned-nwords 8) 3) + ((<= aligned-nwords 16) (setq aligned-nwords 16) 4) + ((<= aligned-nwords 24) (setq aligned-nwords 24) 5) + ((<= aligned-nwords 32) (setq aligned-nwords 32) 6) + ((<= aligned-nwords 48) (setq aligned-nwords 48) 7) (t (error "Oversized layout")))) ;; TODO: allow different sizes of funcallable-instance - (#.funcallable-instance-widetag 7)))) + (#.funcallable-instance-widetag 8)))) (values (%primitive alloc-immobile-fixedobj size-class aligned-nwords @@ -411,13 +430,11 @@ (alloc-immobile-fixedobj symbol-size (logior (ash (1- symbol-size) n-widetag-bits) symbol-widetag))))) - ;; no pin, it's immobile (and obviously live) - (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address symbol)) - (- (ash symbol-name-slot word-shift) other-pointer-lowtag)) - name) + ;; symbol-hash was initialized to 0 (%set-symbol-global-value symbol (make-unbound-marker)) - ;; symbol-hash is 0 - (setf (symbol-info symbol) nil) + (setf (symbol-%info symbol) nil) + (%primitive sb-vm::set-slot symbol name + 'make-symbol sb-vm:symbol-name-slot sb-vm:other-pointer-lowtag) (%set-symbol-package symbol nil) symbol)) @@ -494,23 +511,31 @@ ;; (Could dead immobile objects be converted to use FILLER-WIDETAG instead?) (unless (immobile-space-obj-p code) ;; Before writing the boxed word count, zeroize up to and including 1 word - ;; after the boxed header so that all point words can be safely read - ;; by GC and so the jump table count word is 0. + ;; after the boxed header so that all pointers can be safely read by GC, + ;; and so that the jump table count word is 0. (loop for byte-index from (ash boxed word-shift) downto (ash 2 word-shift) by n-word-bytes - do (setf (sap-ref-word sap byte-index) 0))) + do (setf (sap-ref-word-jit sap byte-index) 0))) ;; The 1st slot beyond the header stores the boxed header size in bytes ;; as an untagged number, which has the same representation as a tagged ;; value denoting a word count if WORD-SHIFT = N-FIXNUM-TAG-BITS. ;; This boxed-size MUST be 0 prior to writing any pointers into the object ;; because the boxed words will not necessarily have been pre-zeroed; ;; scavenging them prior to zeroing them out would see wild pointers. - (setf (sap-ref-word sap (ash code-boxed-size-slot word-shift)) + (setf (sap-ref-word-jit sap (ash code-boxed-size-slot word-shift)) ;; For 32-bit words, we'll have to add another primitive-object slot. ;; But so far nothing makes use of the n-named-calls value. (logior #+64-bit (ash n-named-calls 32) (ash boxed word-shift))))) + ;; FIXME: there may be random values in the unboxed payload and it's not obvious + ;; that all callers of ALLOCATE-CODE-OBJECT always write all raw bytes. + ;; LOAD-CODE and MAKE-CORE-COMPONENT certainly do because the representation + ;; of simple-funs requires that the final 2 bytes be aligned to the physical end + ;; of the object so that we can find the function table. + ;; But what about other things that create code objects? + ;; It could be a subtle source of nondeterministic core images. + ;; FIXME: Sort out 64-bit and cheneygc. #+(and 64-bit cheneygc) (setf (code-header-ref code 0) diff -Nru sbcl-2.1.1/src/code/ansi-stream.lisp sbcl-2.1.11/src/code/ansi-stream.lisp --- sbcl-2.1.1/src/code/ansi-stream.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/ansi-stream.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -130,13 +130,16 @@ (in-index +ansi-stream-in-buffer-length+ :type (integer 0 #.+ansi-stream-in-buffer-length+)) + ;; FIXME: declare all these function types more rigorously. + ;; buffered input functions (in #'ill-in :type function) ; READ-CHAR function (bin #'ill-bin :type function) ; byte input function ;; 'n-bin' might not transfer bytes to the consumer. ;; A character FD-STREAM uses this method to transfer octets from the ;; source buffer into characters of the destination buffer. - (n-bin #'ill-bin :type function) ; n-byte input function + (n-bin #'ill-bin :type ; n-byte input function + (sfunction (stream (simple-unboxed-array (*)) index index t) index)) ;; output functions (out #'ill-out :type function) ; WRITE-CHAR function @@ -169,6 +172,22 @@ (symbol nil :type symbol :read-only t)) (declaim (freeze-type synonym-stream)) +(defstruct (broadcast-stream (:include ansi-stream + (out #'broadcast-out) + (bout #'broadcast-bout) + (sout #'broadcast-sout) + (misc #'broadcast-misc)) + (:constructor %make-broadcast-stream + (streams)) + (:copier nil) + (:predicate nil)) + ;; a list of all the streams we broadcast to + (streams () :type list :read-only t)) +(declaim (freeze-type broadcast-stream)) + +(define-load-time-global *null-broadcast-stream* (make-broadcast-stream)) +(declaim (type stream *null-broadcast-stream*)) + (defmethod print-object ((x stream) stream) (print-unreadable-object (x stream :type t :identity t))) diff -Nru sbcl-2.1.1/src/code/aprof.lisp sbcl-2.1.11/src/code/aprof.lisp --- sbcl-2.1.1/src/code/aprof.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/aprof.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -64,11 +64,11 @@ (defpackage #:sb-aprof (:use #:cl #:sb-ext #:sb-alien #:sb-sys #:sb-int #:sb-kernel) - (:export #:aprof-run #:aprof-show) + (:export #:aprof-run #:aprof-show #:aprof-reset) (:import-from #:sb-di #:valid-lisp-pointer-p) - (:import-from #:sb-vm #:rbp-offset) + (:import-from #:sb-vm #:thread-reg) (:import-from #:sb-x86-64-asm - #:get-gpr #:reg #:reg-num + #:register-p #:get-gpr #:reg #:reg-num #:machine-ea #:machine-ea-p #:machine-ea-disp #:machine-ea-base #:machine-ea-index #:inc #:add #:mov)) @@ -80,10 +80,7 @@ bytes count type pc) (declaim (freeze-type alloc)) -(defvar *allocation-profile-metadata* nil) - -(defvar *allocation-fixups-installed* - (make-hash-table :test 'eq :weakness :key :synchronized t)) +(defglobal *allocation-profile-metadata* nil) (define-alien-variable alloc-profile-buffer system-area-pointer) (defun aprof-reset () @@ -93,22 +90,25 @@ (* (/ (length *allocation-profile-metadata*) 2) sb-vm:n-word-bytes))) -(defun patch-fixups () - (let ((n-fixups 0) - (n-patched 0) - (from-ht sb-c::*allocation-point-fixups*) - (to-ht *allocation-fixups-installed*)) - (when (plusp (hash-table-count from-ht)) - (dohash ((code fixups) from-ht) - (do-packed-varints (loc fixups) - (incf n-fixups) - (let ((byte (sap-ref-8 (code-instructions code) loc))) - (when (eql byte #xEB) - (setf (sap-ref-8 (code-instructions code) loc) #x74) ; JEQ - (incf n-patched)))) - (setf (gethash code to-ht) fixups) - (remhash code from-ht))) - (values n-fixups n-patched))) +(defun patch-code (code locs &aux (n 0) (n-patched 0)) + (do-packed-varints (loc locs) + (incf n) + (let ((byte (sap-ref-8 (code-instructions code) loc))) + (when (eql byte #xEB) + (setf (sap-ref-8 (code-instructions code) loc) #x74) ; JEQ + (incf n-patched)))) + (values n n-patched)) + +(defun patch-all-code () + (let ((total-n-patch-points 0) + (total-n-patched 0) + (ht sb-c::*allocation-patch-points*)) + (dohash ((code locs) ht) + (remhash code ht) + (multiple-value-bind (n-patch-points n-patched) (patch-code code locs) + (incf total-n-patch-points n-patch-points) + (incf total-n-patched n-patched))) + (values total-n-patch-points total-n-patched))) (defun aprof-start () (let ((v *allocation-profile-metadata*)) @@ -136,34 +136,13 @@ (defun layout-name (ptr) (if (eql (valid-lisp-pointer-p (int-sap ptr)) 0) 'structure - (layout-classoid-name (make-lisp-obj ptr)))) + (wrapper-classoid-name (layout-friend (make-lisp-obj ptr))))) ;;; These EAs are s-expressions, not instances of EA or MACHINE-EA. +#-sb-safepoint (defconstant-eqx p-a-flag `(ea ,(ash sb-vm::thread-pseudo-atomic-bits-slot sb-vm:word-shift) - ,(get-gpr :qword (sb-c:tn-offset sb-vm::thread-base-tn))) - #'equal) -(defconstant-eqx region-ptr - `(ea ,(ash sb-vm::thread-alloc-region-slot sb-vm:word-shift) - ,(get-gpr :qword (sb-c:tn-offset sb-vm::thread-base-tn))) + ,(get-gpr :qword sb-vm::thread-reg)) #'equal) -(defconstant-eqx region-end - `(ea ,(ash (1+ sb-vm::thread-alloc-region-slot) sb-vm:word-shift) - ,(get-gpr :qword (sb-c:tn-offset sb-vm::thread-base-tn))) - #'equal) - -(defun header-word-store-p (inst bindings) - ;; a byte-sized or word-sized store at displacement 8 through 10 is OK - (let ((ea (caddr inst)) - (freeptr (cdr (assoc '$free bindings)))) - (and (eq (car inst) 'mov) - (typep ea 'machine-ea) - (typep freeptr 'reg) - (eql (reg-num freeptr) (machine-ea-base ea)) - (or (and (member (cadr inst) '(:byte :word)) - (typep (machine-ea-disp ea) '(integer 8 10))) - (and (eq (cadr inst) :qword) - (eql (machine-ea-disp ea) 8) - (typep (cadddr inst) 'reg)))))) ;;; Templates to try in order. The one for unknown headered objects should be last ;;; so that we try to match a store to the header word if possible. @@ -173,47 +152,85 @@ ;;; "don't know how to dump R13 (default MAKE-LOAD-FORM method called)." #-sb-show (setq *allocation-templates* - `((array ;; also array-header - (xadd $free $size) - (cmp :qword $free ,region-end) - (jmp :nbe $_) - (mov :qword ,region-ptr $free) - (mov $_ (ea 0 $size) $header); after XADD, size is the old free ptr - (:optional (mov $_ (ea 8 $size) $vector-len)) - (:or (or $size ,sb-vm:other-pointer-lowtag) - (lea :qword $result (ea ,sb-vm:other-pointer-lowtag $size)))) + `((fixed+header + (add ?end ?nbytes) + (cmp :qword ?end :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?end) + (add ?end ?bias) + (mov ?_ (ea ?_ ?end) ?header)) + + (var-array + (add ?end ?nbytes) + (cmp :qword ?end :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?end) + (sub ?end ?nbytes) + (mov ?_ (ea ?_ ?end) ?header) + (mov ?_ (ea ?_ ?end) ?vector-len)) + + (var-xadd + ;; after the xadd, SIZE holds the original value of free-ptr + ;; and free-ptr points to the end of the putative data block. + (xadd ?free ?size) + (cmp :qword ?free :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?free) + ;; Could have one or two stores prior to ORing in a lowtag. + (:optional (mov ?_ (ea 0 ?size) ?header)) + (:optional (mov ?_ (ea 8 ?size) ?vector-len)) + (:or (or ?size ?lowtag) + (lea :qword ?result (ea ?lowtag ?size)))) - (any (:or (lea :qword $end (ea $nbytes $free $nbytes-var)) + (any (:or (lea :qword ?end (ea ?nbytes ?free ?nbytes-var)) ;; LEA with scale=1 can have base and index swapped - (lea :qword $end (ea 0 $nbytes-var $free)) - (add $end $free)) ; $end originally holds the size in bytes - (cmp :qword $end ,region-end) - (jmp :nbe $_) - (mov :qword ,region-ptr $end) - (mov $_ (ea 0 $free) $header) - (:optional (:if header-word-store-p (mov $_ (ea $_ $free) $vector-len))) - (:or (or $free $lowtag) - (lea :qword $result (ea $lowtag $free)))) + (lea :qword ?end (ea 0 ?nbytes-var ?free)) + (add ?end ?free)) ; ?end originally holds the size in bytes + (cmp :qword ?end :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?end) + (mov ?_ (ea 0 ?free) ?header) + (:optional (mov ?_ (ea ?_ ?free) ?vector-len)) + (:or (or ?free ?lowtag) + (lea :qword ?result (ea ?lowtag ?free)))) + + ;; LISTIFY-REST-ARG computes a tagged pointer to the _last_ cons in the memory block, + ;; not the first cons. + (list (lea :qword ?end (ea 0 ?nbytes ?free)) + (cmp :qword ?end :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?end) + (lea :qword ?free (ea ,(- sb-vm:list-pointer-lowtag + (* sb-vm:cons-size sb-vm:n-word-bytes)) + ?free ?nbytes)) + (shr ?nbytes 4)) + + (acons (lea :qword ?end (ea 32 ?free)) + (cmp :qword ?end :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?end) + (:repeat (mov . ignore)) + (lea :qword ?result (ea #.(+ 16 sb-vm:list-pointer-lowtag) ?free))) ;; either non-headered object (cons) or unknown header or unknown nbytes - (unknown-header (:or (lea :qword $end (ea $nbytes $free $nbytes-var)) - (lea :qword $end (ea 0 $nbytes-var $free)) - (add $end $free)) - (cmp :qword $end ,region-end) - (jmp :nbe $_) - (mov :qword ,region-ptr $end) + (unknown-header (:or (lea :qword ?end (ea ?nbytes ?free ?nbytes-var)) + (lea :qword ?end (ea 0 ?nbytes-var ?free)) + (add ?end ?free)) + (cmp :qword ?end :tlab-limit) + (jmp :nbe ?_) + (mov :qword :tlab-freeptr ?end) (:repeat (:or (mov . ignore) (lea . ignore))) - (:or (or $free $lowtag) - (lea :qword $result (ea $lowtag $free)))))) + (:or (or ?free ?lowtag) + (lea :qword ?result (ea ?lowtag ?free)))))) (defglobal *allocation-templates-large* nil) (setq *allocation-templates-large* - `((array (push $nbytes) + `((array (push ?nbytes) (call . ignore) - (pop $result) - (mov $_ (ea 0 $result) $header) - (mov $_ (ea $_ $result) $vector-len) - (or $result $lowtag)))) + (pop ?result) + (mov ?_ (ea 0 ?result) ?header) + (mov ?_ (ea ?_ ?result) ?vector-len) + (or ?result ?lowtag)))) (defun iterator-begin (iterator pc code) (let ((segment (sb-disassem:make-code-segment @@ -233,15 +250,30 @@ ;; FIXME: this drops any LOCK prefix, but that seems to be ok (do ((tail (cdr inst) (cdr tail))) ((null tail)) + ;; This takes an instruction expressed thusly: + ;; (MOV (#S(MACHINE-EA :DISP n :BASE n) . :QWORD) RDX) + ;; and turns it into: + ;; (MOV :QWORD #S(MACHINE-EA :DISP n :BASE n) RDX) (when (typep (car tail) '(cons machine-ea)) - (setf inst (list* (car inst) (cdar tail) (cdr inst)) - (car tail) (caar tail)) + (let ((ea (caar tail))) + (setf inst (list* (car inst) (cdar tail) (cdr inst))) ; insert the :size) + (when (eq (machine-ea-base ea) sb-vm::thread-reg) + ;; Figure out if we're looking at an allocation buffer + (let ((disp (ash (machine-ea-disp ea) (- sb-vm:word-shift)))) + (awhen (case disp + ((#.sb-vm::thread-boxed-tlab-slot + #.sb-vm::thread-unboxed-tlab-slot) :tlab-freeptr) + ((#.(1+ sb-vm::thread-boxed-tlab-slot) + #.(1+ sb-vm::thread-unboxed-tlab-slot)) :tlab-limit)) + (setq ea it)))) + (setf (car tail) ea)) ; change the EA + ;; There can be at most one EA per instruction, so we're done (return))) (vector-push-extend inst vector) inst)))) (defparameter *debug-deduce-type* nil) -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :execute) (defmacro note (&rest args) `(when *debug-deduce-type* (let ((*print-pretty* nil)) @@ -272,8 +304,8 @@ (note " match-atom ~s ~s ~s ~s~%" pattern input ea-reg-p bindings) (when (and (integerp input) ea-reg-p) (setq input (get-gpr :qword input))) - (cond ((eq pattern '$_) t) ; match and ignore anything - ((and (symbolp pattern) (char= (char (string pattern) 0) #\$)) + (cond ((eq pattern '?_) t) ; match and ignore anything + ((and (symbolp pattern) (char= (char (string pattern) 0) #\?)) ;; free variable binds to input, otherwise binding must match (let* ((cell (assq pattern bindings)) (binding (cdr cell))) @@ -288,7 +320,7 @@ (t (eql pattern input)))) (ok-binding (pattern input) (case pattern - ($lowtag + (?lowtag (memq input `(,sb-vm:instance-pointer-lowtag ,sb-vm:list-pointer-lowtag ,sb-vm:fun-pointer-lowtag ,sb-vm:other-pointer-lowtag))) (t t)))) @@ -326,33 +358,49 @@ (loop (when (endp template) (return bindings)) (let ((pattern (pop template))) (case (car pattern) - ((:optional :repeat) - (let ((count (if (eq (car pattern) :repeat) most-positive-fixnum 1))) - ;; :REPEAT matches zero or more instructions, but as few as possible. - ;; :OPTIONAL matches zero or one, similarly. + (:optional + ;; :OPTIONAL is greedy, preferring to match if it can, + ;; but if the rest of the template fails, we'll backtrack + ;; and skip this pattern. + (when (inst-matchp input (cadr pattern)) + (let ((bindings (matchp input template bindings))) + (cond ((eq bindings :fail) + (setf (car input) start)) ; don't match + (t + (return bindings)))))) + (:repeat + ;; :REPEAT matches zero or more instructions, as few as possible. (let ((next-pattern (pop template))) (loop (when (inst-matchp input next-pattern) (return)) - (unless (and (>= (decf count) 0) - (inst-matchp input (cadr pattern))) - (fail)))))) + (unless (inst-matchp input (cadr pattern)) + (fail))))) (t (unless (inst-matchp input pattern) (fail)))))))) (defun deduce-layout (iterator bindings) - (unless (assq '$result bindings) - (push `($result . ,(cdr (assq '$free bindings))) bindings)) + (unless (assq '?result bindings) + (push `(?result . ,(cdr (assq '?free bindings))) bindings)) (let ((bindings (matchp iterator + ;; instance allocation completes the pseudoatomic part after storing widetag + ;; and length, before storing the layout; so we look for either pending-interrupt + ;; or safepoint trap in between some stores. (load-time-value - `((xor :qword ,p-a-flag ,(get-gpr :qword rbp-offset)) - (jmp :eq $_) - (break . ignore) - (mov :dword (ea 1 $result) $layout)) t) + #+sb-safepoint + `((test :byte ,(get-gpr :byte sb-vm::rax-offset) + (ea ,(- sb-vm:static-space-start sb-vm:gc-safepoint-trap-offset) nil)) + (mov :dword (ea 1 ?result) ?layout)) + #-sb-safepoint + `((xor :qword ,p-a-flag ,(get-gpr :qword thread-reg)) + (jmp :eq ?_) + #+linux (icebp) #-linux (break . ignore) + (mov :dword (ea 1 ?result) ?layout)) + t) bindings))) (if (eq bindings :fail) 'instance - (layout-name (cdr (assq '$layout bindings)))))) + (layout-name (cdr (assq '?layout bindings)))))) (defun deduce-fun-subtype (iterator bindings) (declare (ignorable iterator bindings)) @@ -361,14 +409,14 @@ (let* ((bindings (matchp iterator (load-time-value - `((mov $scratch $header) - (or :qword $scratch + `((mov ?scratch ?header) + (or :qword ?scratch (ea ,(ash sb-vm::thread-function-layout-slot sb-vm:word-shift) - ,(get-gpr :qword (sb-c:tn-offset sb-vm::thread-base-tn)))) - (mov :qword (ea ,(- sb-vm:fun-pointer-lowtag) $result) $scratch)) + ,(get-gpr :qword sb-vm::thread-reg))) + (mov :qword (ea ,(- sb-vm:fun-pointer-lowtag) ?result) ?scratch)) t) bindings)) - (header (and (listp bindings) (cdr (assoc '$header bindings))))) + (header (and (listp bindings) (cdr (assoc '?header bindings))))) (if (and (integerp header) (eq (logand header #xFF) sb-vm:closure-widetag)) 'closure 'function))) @@ -382,35 +430,31 @@ (let* ((inst (get-instruction iterator)) (ea (third inst))) ; (INC :qword EA) (when (and (eq (car inst) 'inc) - (eql (machine-ea-base ea) (sb-c:tn-offset sb-vm::temp-reg-tn)) + (machine-ea-base ea) (null (machine-ea-index ea))) (incf (car iterator)) - (let ((profiler-index (machine-ea-disp ea))) + (let ((profiler-base (machine-ea-base ea)) + (profiler-index (machine-ea-disp ea))) ;; Optional: the total number of bytes at the allocation point (let* ((inst (get-instruction iterator)) (ea (third inst))) (when (and (eq (car inst) 'add) (machine-ea-p ea) - (eql (machine-ea-base ea) (sb-c:tn-offset sb-vm::temp-reg-tn)) + (eql (machine-ea-base ea) profiler-base) (null (machine-ea-index ea)) (eql (machine-ea-disp ea) (+ profiler-index sb-vm:n-word-bytes))) (incf (car iterator))))))) ;; Expect a store to the pseudo-atomic flag + #-sb-safepoint (when (eq (matchp iterator - (load-time-value `((mov :qword ,p-a-flag ,(get-gpr :qword rbp-offset))) t) + (load-time-value `((mov :qword ,p-a-flag ,(get-gpr :qword thread-reg))) t) nil) :fail) (return-from deduce-type (values nil nil))) (let* ((type) (bindings - (matchp iterator - ;; compiler bug? If expressed with "`" then the compiler tries to - ;; refer to the undumpable constant REGION-PTR by its value, not by its - ;; name, then complaining that it can't be dumped. - ;; Why is ",P-A-FLAG" acceptable but this not? - (load-time-value (list (list 'mov :qword '$free region-ptr)) t) - nil)) + (matchp iterator `((mov :qword ?free :tlab-freeptr)) nil)) (templates (cond (template-name (list (find template-name *allocation-templates* :key 'car))) @@ -428,9 +472,9 @@ (return)))) (if (eq bindings :fail) (values nil nil) - (let ((nbytes (cdr (assoc '$nbytes bindings))) - (header (cdr (assoc '$header bindings))) - (lowtag (cdr (assoc '$lowtag bindings)))) + (let ((nbytes (cdr (assoc '?nbytes bindings))) + (header (cdr (assoc '?header bindings))) + (lowtag (cdr (assoc '?lowtag bindings)))) ;; The low bit might signify something to the allocator. Clear it. (when (integerp nbytes) (setq nbytes (logandc2 nbytes 1))) @@ -439,11 +483,17 @@ ;; when register indirect mode is used without a SIB byte. (when (eq nbytes 0) (setq nbytes nil)) - (cond ((and (member type '(array any)) + (cond ((and (member type '(fixed+header var-array var-xadd any)) (typep header '(or sb-vm:word sb-vm:signed-word))) (setq type (aref *tag-to-type* (logand header #xFF))) + (when (register-p nbytes) + (setq nbytes nil)) (when (eq type 'instance) (setq type (deduce-layout iterator bindings)))) + ((eq type 'list) ; listify-rest-arg + (setq nbytes nil)) + ((eq type 'acons) + (setq type 'list nbytes (* 2 sb-vm:cons-size sb-vm:n-word-bytes))) ((member type '(any unknown-header)) (setq type (case lowtag (#.sb-vm:list-pointer-lowtag 'list) @@ -625,16 +675,20 @@ ;;; cons profiling. ;;; STREAM is where to report, defaulting to *standard-output*. ;;; The convention is that of map-segment-instructions, meaning NIL is a sink. -(defun aprof-run (fun &key (stream *standard-output*)) +(defun aprof-run (fun &key (report t) (stream *standard-output*) arguments) (aprof-reset) - (patch-fixups) - (let (nbytes) - (unwind-protect - (progn (aprof-start) (funcall fun)) - (aprof-stop) - (setq nbytes (aprof-show :stream stream)) - (when stream (terpri stream))) - nbytes)) + (patch-all-code) + (dx-let ((arglist (cons arguments nil))) ; so no consing in here + (when (listp arguments) + (setq arglist (car arglist))) ; was already a list + (let (nbytes) + (unwind-protect + (progn (aprof-start) (apply fun arglist)) + (aprof-stop)) + (when report + (setq nbytes (aprof-show :stream stream)) + (when stream (terpri stream))) + nbytes))) ;;;; diff -Nru sbcl-2.1.1/src/code/arm64-vm.lisp sbcl-2.1.11/src/code/arm64-vm.lisp --- sbcl-2.1.1/src/code/arm64-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/arm64-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -6,6 +6,9 @@ "Return a string describing the type of the local machine." "ARM64") +(defun return-machine-address (scp) + (context-register scp lr-offset)) + ;;;; "Sigcontext" access functions, cut & pasted from sparc-vm.lisp, ;;;; then modified for ARM. ;;;; @@ -50,16 +53,42 @@ ;;; Given a (POSIX) signal context, extract the internal error ;;; arguments from the instruction stream. +;;; +;;; See EMIT-ERROR-BREAK for the scheme (defun internal-error-args (context) (declare (type (alien (* os-context-t)) context)) (let* ((pc (context-pc context)) (instruction (sap-ref-32 pc 0)) - (error-number (ldb (byte 8 13) instruction)) - (trap-number (ldb (byte 8 5) instruction))) + (trap-number (ldb (byte 8 5) instruction)) + (error-number (cond + ((>= trap-number sb-vm:error-trap) + (prog1 + (- trap-number sb-vm:error-trap) + (setf trap-number sb-vm:error-trap))) + (t + (prog1 (sap-ref-8 pc 4) + (setf pc (sap+ pc 1)))))) + (first-arg (ldb (byte 8 13) instruction))) (declare (type system-area-pointer pc)) (if (= trap-number invalid-arg-count-trap) - (values error-number '(#.arg-count-sc) trap-number) - (sb-kernel::decode-internal-error-args (sap+ pc 4) trap-number error-number)))) + (values #.(error-number-or-lose 'invalid-arg-count-error) + '(#.arg-count-sc) + trap-number) + (let ((length (sb-kernel::error-length error-number))) + (declare (type (unsigned-byte 8) length)) + (unless (or (= first-arg zr-offset) + (zerop length)) + (decf length)) + (setf pc (sap+ pc 4)) + (let ((args (loop repeat length + with index = 0 + collect (sb-c:sap-read-var-integerf pc index)))) + (values error-number + (if (= first-arg zr-offset) + args + (cons (make-sc+offset sb-vm:descriptor-reg-sc-number first-arg) + args)) + trap-number)))))) ;;; Undo the effects of XEP-ALLOCATE-FRAME ;;; and point PC to FUNCTION @@ -78,3 +107,62 @@ (setf (context-register context lexenv-offset) fun-addr (context-register context lr-offset) entry) (set-context-pc context entry))))) + +#+darwin-jit +(progn + (define-alien-routine jit-patch + void + (address unsigned) + (value unsigned)) + + (define-alien-routine jit-patch-code + void + (code unsigned) + (value unsigned) + (index unsigned)) + + (define-alien-routine jit-patch-int + void + (address unsigned) + (value int)) + + (define-alien-routine jit-patch-uint + void + (address unsigned) + (value unsigned-int)) + + (define-alien-routine jit-patch-uchar + void + (address unsigned) + (value unsigned-char)) + + (define-alien-routine jit-memcpy + void + (dst (* char)) + (src (* char)) + (char signed)) + + (defun (setf sap-ref-word-jit) (value sap offset) + (jit-patch (+ (sap-int sap) offset) value)) + + (defun (setf signed-sap-ref-32-jit) (value sap offset) + (jit-patch-int (+ (sap-int sap) offset) value)) + + (defun signed-sap-ref-32-jit (sap offset) + (signed-sap-ref-32 sap offset)) + + (defun (setf sap-ref-32-jit) (value sap offset) + (jit-patch-uint (+ (sap-int sap) offset) value)) + + (defun sap-ref-32-jit (sap offset) + (sap-ref-32 sap offset)) + + (defun (setf sap-ref-8-jit) (value sap offset) + (jit-patch-uchar (+ (sap-int sap) offset) value)) + + (defun (setf code-header-ref) (value code index) + (with-pinned-objects (code value) + (jit-patch-code (get-lisp-obj-address code) + (get-lisp-obj-address value) + index)) + value)) diff -Nru sbcl-2.1.1/src/code/arm-vm.lisp sbcl-2.1.11/src/code/arm-vm.lisp --- sbcl-2.1.1/src/code/arm-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/arm-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -5,6 +5,10 @@ (defun machine-type () "Return a string describing the type of the local machine." "ARM") + +(defun return-machine-address (scp) + (context-register scp lr-offset)) + ;;;; "Sigcontext" access functions, cut & pasted from sparc-vm.lisp, ;;;; then modified for ARM. diff -Nru sbcl-2.1.1/src/code/array.lisp sbcl-2.1.11/src/code/array.lisp --- sbcl-2.1.1/src/code/array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -31,18 +31,12 @@ (def %array-displaced-p) (def %array-displaced-from)) -;;; For compatibility: DO NOT USE IN NEW CODE. -(defun %array-data-vector (array) (%array-data array)) - (defun %array-rank (array) (%array-rank array)) (defun %array-dimension (array axis) (%array-dimension array axis)) -(defun %set-array-dimension (array axis value) - (%set-array-dimension array axis value)) - (defun %check-bound (array bound index) (declare (type index bound) (fixnum index)) @@ -347,15 +341,6 @@ #.complex-vector-widetag)))) (make-case))) -(define-load-time-global %%simple-array-n-bits-shifts%% - (make-array (1+ widetag-mask))) -#.(loop for info across *specialized-array-element-type-properties* - collect `(setf (aref %%simple-array-n-bits-shifts%% ,(saetp-typecode info)) - ,(saetp-n-bits-shift info)) into forms - finally (return `(progn ,@forms))) - -(declaim (type (simple-vector #.(1+ widetag-mask)) %%simple-array-n-bits-shifts%%)) - (declaim (inline vector-length-in-words)) (defun vector-length-in-words (length n-bits-shift) (declare (type (integer 0 7) n-bits-shift)) @@ -364,62 +349,85 @@ (1- (integer-length n-word-bits))))) (ash (+ length mask) shift))) -;;; N-BITS-SHIFT is the shift amount needed to turn LENGTH into bits -;;; or NIL, %%simple-array-n-bits-shifts%% will be used in that case. -(defun allocate-vector-with-widetag (widetag length n-bits-shift) +;;; N-BITS-SHIFT is the shift amount needed to turn LENGTH into array-size-in-bits, +;;; i.e. log(2,bits-per-elt) +(defun allocate-vector-with-widetag (#+ubsan poisoned widetag length n-bits-shift) (declare (type (unsigned-byte 8) widetag) (type index length)) - (let* ((n-bits-shift (or n-bits-shift - (aref %%simple-array-n-bits-shifts%% widetag))) - (full-length (if (or (= widetag simple-base-string-widetag) - #+sb-unicode - (= widetag - simple-character-string-widetag)) - (1+ length) - length))) - ;; Be careful not to allocate backing storage for element type NIL. - ;; Both it and type BIT have N-BITS-SHIFT = 0, so the determination - ;; of true size can't be left up to VECTOR-LENGTH-IN-WORDS. - (allocate-vector widetag length - (if (/= widetag simple-array-nil-widetag) - (vector-length-in-words full-length n-bits-shift) - 0)))) + (let* ( ;; KLUDGE: add SAETP-N-PAD-ELEMENTS "by hand" since there is + ;; but a single case involving it now. + (full-length (+ length (if (= widetag simple-base-string-widetag) 1 0))) + ;; Be careful not to allocate backing storage for element type NIL. + ;; Both it and type BIT have N-BITS-SHIFT = 0, so the determination + ;; of true size can't be left up to VECTOR-LENGTH-IN-WORDS. + ;; VECTOR-LENGTH-IN-WORDS potentially returns a machine-word-sized + ;; integer, so it doesn't match the primitive type restriction of + ;; POSITIVE-FIXNUM for the last argument of the vector alloc vops. + (nwords (the fixnum + (if (/= widetag simple-array-nil-widetag) + (vector-length-in-words full-length n-bits-shift) + 0)))) + #+ubsan (if poisoned ; first arg to allocate-vector must be a constant + (allocate-vector t widetag length nwords) + (allocate-vector nil widetag length nwords)) + #-ubsan (allocate-vector widetag length nwords))) +(declaim (ftype (sfunction (array) (integer 128 255)) array-underlying-widetag)) (defun array-underlying-widetag (array) - (macrolet ((make-case () - `(case widetag - ,@(loop for saetp across *specialized-array-element-type-properties* - for complex = (saetp-complex-typecode saetp) - when complex - collect (list complex (saetp-typecode saetp))) - ((,simple-array-widetag - ,complex-vector-widetag - ,complex-array-widetag) - (with-array-data ((array array) (start) (end)) - (declare (ignore start end)) - (%other-pointer-widetag array))) - (t - widetag)))) - (let ((widetag (%other-pointer-widetag array))) - (make-case)))) - -(defun sb-impl::make-vector-like (vector length) - (allocate-vector-with-widetag (array-underlying-widetag vector) length nil)) + (macrolet ((generate-table () + (macrolet ((to-index (x) `(ash ,x -2))) + (let ((table (sb-xc:make-array 64 :initial-element 0 + :element-type '(unsigned-byte 8)))) + (dovector (saetp *specialized-array-element-type-properties*) + (let* ((typecode (saetp-typecode saetp)) + (complex-typecode (saetp-complex-typecode saetp))) + (setf (aref table (to-index typecode)) typecode) + (when complex-typecode + (setf (aref table (to-index complex-typecode)) typecode)))) + (setf (aref table (to-index simple-array-widetag)) 0 + (aref table (to-index complex-vector-widetag)) 0 + (aref table (to-index complex-array-widetag)) 0) + table))) + (to-index (x) `(ash ,x -2))) + (named-let recurse ((x array)) + (let ((result (aref (generate-table) + (to-index (%other-pointer-widetag x))))) + (if (= 0 result) + (recurse (%array-data x)) + (truly-the (integer 128 255) result)))))) -;; Complain in various ways about wrong :INITIAL-foo arguments, +;; Complain in various ways about wrong MAKE-ARRAY and ADJUST-ARRAY arguments, ;; returning the two initialization arguments needed for DATA-VECTOR-FROM-INITS. -(defun validate-array-initargs (element-p element contents-p contents displaced) - (cond ((and displaced (or element-p contents-p)) - (if (and element-p contents-p) - (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ - may be specified with the :DISPLACED-TO option") - (error "~S may not be specified with the :DISPLACED-TO option" - (if element-p :initial-element :initial-contents)))) - ((and element-p contents-p) - (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) - (element-p (values :initial-element element)) - (contents-p (values :initial-contents contents)) - (t (values nil nil)))) +;; This is an unhygienic macro which would be a MACROLET other than for +;; doing so would entail moving toplevel defuns around for no good reason. +(defmacro check-make-array-initargs (displaceable &optional element-type size) + `(cond ,@(when displaceable + `((displaced-to + (when (or element-p contents-p) + (if (and element-p contents-p) + (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ + may be specified with the :DISPLACED-TO option") + (error "~S may not be specified with the :DISPLACED-TO option" + (if element-p :initial-element :initial-contents)))) + (unless (= (array-underlying-widetag displaced-to) widetag) + ;; Require exact match on upgraded type (lp#1331299) + (error "Can't displace an array of type ~/sb-impl:print-type-specifier/ ~ + into another of type ~/sb-impl:print-type-specifier/" + ,element-type (array-element-type displaced-to))) + (when (< (array-total-size displaced-to) + (+ displaced-index-offset ,size)) + (error "The :DISPLACED-TO array is too small."))) + (offset-p + (error "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")))) + ((and element-p contents-p) + (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) + (element-p (values :initial-element initial-element)) + (contents-p (values :initial-contents initial-contents)))) +(defmacro make-array-bad-fill-pointer (actual max adjective) + ;; There was a comment implying that this should be TYPE-ERROR + ;; but I don't see that as a spec requirement. + `(error "Can't supply a value for :FILL-POINTER (~S) that is larger ~ + than the~A size of the vector (~S)" ,actual ,adjective ,max)) (declaim (inline %save-displaced-array-backpointer)) (defun %save-displaced-array-backpointer (array data) @@ -439,79 +447,95 @@ (setf (%array-displaced-from old-data) (purge (%array-displaced-from old-data))))))) -(sb-c::unless-vop-existsp (:translate set-header-bits) - (declaim (inline set-header-bits unset-header-bits)) - (defun set-header-bits (vector bits) - (set-header-data vector (logior (get-header-data vector) bits)) - (values)) - (defun unset-header-bits (vector bits) - (set-header-data vector (logand (get-header-data vector) - (ldb (byte (- sb-vm:n-word-bits sb-vm:n-widetag-bits) 0) - (lognot bits)))) - (values))) +(defmacro populate-dimensions (header list-or-index rank) + `(if (listp ,list-or-index) + (let ((dims ,list-or-index)) + (dotimes (axis ,rank) + (declare ((integer 0 ,array-rank-limit) axis)) + (%set-array-dimension ,header axis (pop dims)))) + (%set-array-dimension ,header 0 ,list-or-index))) + +(declaim (inline rank-and-total-size-from-dims)) +(defun rank-and-total-size-from-dims (dims) + (cond ((not (listp dims)) (values 1 (the index dims))) + ((not dims) (values 0 1)) + (t (let ((rank 1) (product (car dims))) + (declare (array-rank rank) (index product)) + (dolist (dim (cdr dims) (values rank product)) + (setq product (* product (the index dim))) + (incf rank)))))) + +(defconstant-eqx +widetag->element-type+ + #.(let ((a (make-array 32 :initial-element 0))) + (dovector (saetp *specialized-array-element-type-properties* a) + (let ((tag (saetp-typecode saetp))) + (setf (aref a (ash (- tag #x80) -2)) (saetp-specifier saetp))))) + #'equalp) + +(declaim (inline widetag->element-type)) +(defun widetag->element-type (widetag) + (svref +widetag->element-type+ (- (ash widetag -2) 32))) ;;; Widetag is the widetag of the underlying vector, ;;; it'll be the same as the resulting array widetag only for simple vectors (defun %make-array (dimensions widetag n-bits &key element-type - (initial-element nil initial-element-p) - (initial-contents nil initial-contents-p) + (initial-element nil element-p) + (initial-contents nil contents-p) adjustable fill-pointer - displaced-to displaced-index-offset) + displaced-to + (displaced-index-offset 0 offset-p)) (declare (ignore element-type)) - (binding* (((array-rank dimension-0) - (if (listp dimensions) - (values (length dimensions) - (if dimensions (car dimensions) 1)) - (values 1 dimensions))) + (binding* (((array-rank total-size) (rank-and-total-size-from-dims dimensions)) ((initialize initial-data) - (validate-array-initargs initial-element-p initial-element - initial-contents-p initial-contents - displaced-to)) + ;; element-type might not be supplied, but widetag->element is always good + (check-make-array-initargs t (widetag->element-type widetag) total-size)) (simple (and (null fill-pointer) (not adjustable) (null displaced-to)))) - (declare (type array-rank array-rank)) - (declare (type index dimension-0)) - (cond ((and displaced-index-offset (null displaced-to)) - (error "Can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) - ((and simple (= array-rank 1)) + + (cond ((and simple (= array-rank 1)) (let ((vector ; a (SIMPLE-ARRAY * (*)) - (allocate-vector-with-widetag widetag dimension-0 n-bits))) + (allocate-vector-with-widetag #+ubsan (not (or element-p contents-p)) + widetag total-size n-bits))) ;; presence of at most one :INITIAL-thing keyword was ensured above - (cond (initial-element-p + (cond (element-p (fill vector initial-element)) - (initial-contents-p + (contents-p (let ((content-length (length initial-contents))) - (unless (= dimension-0 content-length) + (unless (= total-size content-length) (error "There are ~W elements in the :INITIAL-CONTENTS, but ~ the vector length is ~W." - content-length dimension-0))) - (replace vector initial-contents))) + content-length total-size))) + (replace vector initial-contents)) + #+ubsan + (t + ;; store the function which bears responsibility for creation of this + ;; array in case we need to blame it for not initializing. + (set-vector-extra-data (if (= widetag simple-vector-widetag) ; no shadow bits. + vector ; use the LENGTH slot directly + (vector-extra-data vector)) + (ash (sap-ref-word (current-fp) n-word-bytes) 3)) ; XXX: magic + (cond ((= widetag simple-vector-widetag) + (fill vector (%make-lisp-obj no-tls-value-marker-widetag))) + ((array-may-contain-random-bits-p widetag) + ;; Leave the last word alone for base-string, + ;; in case the mandatory trailing null is part of a data word. + (dotimes (i (- (vector-length-in-words total-size n-bits) + (if (= widetag simple-base-string-widetag) 1 0))) + (setf (%vector-raw-bits vector i) sb-ext:most-positive-word)))))) vector)) - ((and (arrayp displaced-to) - (/= (array-underlying-widetag displaced-to) widetag)) - (error "Array element type of :DISPLACED-TO array does not match specified element type")) (t ;; it's non-simple or multidimensional, or both. (when fill-pointer (unless (= array-rank 1) (error "Only vectors can have fill pointers.")) - (when (and (integerp fill-pointer) (> fill-pointer dimension-0)) - ;; FIXME: should be TYPE-ERROR? - (error "invalid fill-pointer ~W" fill-pointer))) - (let* ((total-size - (if (consp dimensions) - (the index (reduce (lambda (a b) (* a (the index b))) - dimensions)) - ;; () is considered to have dimension-0 = 1. - ;; It avoids the REDUCE lambda being called with no args. - dimension-0)) - (data (or displaced-to - (data-vector-from-inits - dimensions total-size nil widetag n-bits - initialize initial-data))) + (when (and (integerp fill-pointer) (> fill-pointer total-size)) + (make-array-bad-fill-pointer fill-pointer total-size ""))) + (let* ((data (or displaced-to + (data-vector-from-inits dimensions total-size widetag n-bits + initialize initial-data))) (array (make-array-header (cond ((= array-rank 1) (%complex-vector-widetag widetag)) @@ -519,11 +543,11 @@ (t complex-array-widetag)) array-rank))) (cond (fill-pointer - (set-header-bits array sb-vm:+array-fill-pointer-p+) + (logior-array-flags array +array-fill-pointer-p+) (setf (%array-fill-pointer array) - (if (eq fill-pointer t) dimension-0 fill-pointer))) + (if (eq fill-pointer t) total-size fill-pointer))) (t - (unset-header-bits array sb-vm:+array-fill-pointer-p+) + (reset-array-flags array +array-fill-pointer-p+) (setf (%array-fill-pointer array) total-size))) (setf (%array-available-elements array) total-size) (setf (%array-data array) data) @@ -538,11 +562,7 @@ (%save-displaced-array-backpointer array data))) (t (setf (%array-displaced-p array) nil))) - (if (listp dimensions) - (let ((dims dimensions)) ; avoid "prevents use of assertion" - (dotimes (axis array-rank) - (setf (%array-dimension array axis) (pop dims)))) - (setf (%array-dimension array 0) dimension-0)) + (populate-dimensions array dimensions array-rank) array))))) (defun make-array (dimensions &rest args @@ -561,8 +581,8 @@ (defun make-static-vector (length &key (element-type '(unsigned-byte 8)) - (initial-contents nil initial-contents-p) - (initial-element nil initial-element-p)) + (initial-contents nil contents-p) + (initial-element nil element-p)) "Allocate vector of LENGTH elements in static space. Only allocation of specialized arrays is supported." ;; STEP 1: check inputs fully @@ -573,9 +593,8 @@ (when (eq t (upgraded-array-element-type element-type)) (error "Static arrays of type ~/sb-impl:print-type-specifier/ not supported." element-type)) - (validate-array-initargs initial-element-p initial-element - initial-contents-p initial-contents nil) ; for effect - (when initial-contents-p + (check-make-array-initargs nil) ; for effect + (when contents-p (unless (= length (length initial-contents)) (error "There are ~W elements in the :INITIAL-CONTENTS, but the ~ vector length is ~W." @@ -585,7 +604,7 @@ (error ":INITIAL-CONTENTS contains elements not of type ~ ~/sb-impl:print-type-specifier/." element-type))) - (when initial-element-p + (when element-p (unless (typep initial-element element-type) (error ":INITIAL-ELEMENT ~S is not of type ~ ~/sb-impl:print-type-specifier/." @@ -596,38 +615,38 @@ (multiple-value-bind (type n-bits-shift) (%vector-widetag-and-n-bits-shift element-type) (let* ((full-length - (if (or (= type simple-base-string-widetag) - #+sb-unicode - (= type - simple-character-string-widetag)) - (1+ length) - length)) + ;; KLUDGE: add SAETP-N-PAD-ELEMENTS "by hand" since there is + ;; but a single case involving it now. + (+ length (if (= type simple-base-string-widetag) 1 0))) (vector (allocate-static-vector type length (vector-length-in-words full-length n-bits-shift)))) - (cond (initial-element-p + (cond (element-p (fill vector initial-element)) - (initial-contents-p + (contents-p (replace vector initial-contents)) (t vector))))) -;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the +#+darwin-jit +(defun make-static-code-vector (length initial-contents) + "Allocate vector of LENGTH elements in static space. Only allocation +of specialized arrays is supported." + (let ((vector (allocate-static-code-vector simple-array-unsigned-byte-8-widetag + length + (* length n-word-bytes)))) + (with-pinned-objects (initial-contents) + (jit-memcpy (vector-sap vector) (vector-sap initial-contents) length)) + vector)) + +;;; DATA-VECTOR-FROM-INITS returns a simple rank-1 array that has the ;;; specified array characteristics. Dimensions is only used to pass ;;; to FILL-DATA-VECTOR for error checking on the structure of ;;; initial-contents. -(defun data-vector-from-inits (dimensions total-size - element-type widetag n-bits - initialize initial-data) - ;; FIXME: element-type can be NIL when widetag is non-nil, - ;; and FILL will check the type, although the error will be not as nice. - ;; (cond (typep initial-element element-type) - ;; (error "~S cannot be used to initialize an array of type ~S." - ;; initial-element element-type)) - (let ((data (if widetag - (allocate-vector-with-widetag widetag total-size n-bits) - (make-array total-size :element-type element-type)))) +(defun data-vector-from-inits (dimensions total-size widetag n-bits initialize initial-data) + (declare (fixnum widetag n-bits)) ; really just that they're non-nil + (let ((data (allocate-vector-with-widetag #+ubsan (not initialize) widetag total-size n-bits))) (ecase initialize (:initial-element (fill (the vector data) initial-data)) @@ -714,6 +733,17 @@ ,@decls (tagbody ,@forms)))))))) +;;; We need this constant to be dumped in such a way that genesis can directly +;;; compute the symbol-value in cold load, and not defer the reference until +;;; *!cold-toplevels* are evaluated. That's because GROW-HASH-TABLE calls REPLACE +;;; which calls VECTOR-REPLACE which tries to reference the array of functions, +;;; which had better not be deferred, or all hell breaks loose. It's actually +;;; tricky to call any function in any file that has its toplevel forms evaluated +;;; later than the current file, because you don't generally know whether code +;;; blobs in that other file have had their L-T-V fixups patched in. +(defconstant-eqx +blt-copier-for-widetag+ #.(make-array 32 :initial-element nil) + #'equalp) + (macrolet ((%ref (accessor-getter extra-params) `(funcall (,accessor-getter array) array index ,@extra-params)) (define (accessor-name slow-accessor-name accessor-getter @@ -804,10 +834,7 @@ (declare (optimize (speed 1) (safety 1))) (the* (,type :context :aref) new-value))) - ;; For specialized arrays, the return from - ;; data-vector-set would have to be reboxed to be a - ;; (Lisp) return value; instead, we use the - ;; already-boxed value as the return. + ;; Low-level setters return no value new-value))) (define-reffers (symbol deffer check-form slow-path) `(progn @@ -828,6 +855,7 @@ collect `(setf (svref ,symbol ,widetag) (,deffer ,saetp ,check-form)))))) (defun !hairy-data-vector-reffer-init () + (!blt-copiers-cold-init +blt-copier-for-widetag+) (define-reffers %%data-vector-reffers%% define-reffer (progn) #'slow-hairy-data-vector-ref) @@ -1012,33 +1040,24 @@ ;;;; miscellaneous array properties +(macrolet ((widetag->type (accessor) + (let ((table + ;; Using unbound-marker for empty elements would be preferable, + ;; but I'd either need a cross-compiler proxy for unbound-marker, + ;; or else wrap a LOAD-TIME-VALUE on the table construction form + ;; which might introduce more order-sensitivity to self-build. + (sb-xc:make-array 32 ;:initial-element (make-unbound-marker) + :initial-element 0))) + (dovector (saetp *specialized-array-element-type-properties*) + (setf (aref table (ash (- (saetp-typecode saetp) 128) -2)) + (funcall accessor saetp))) + `(aref ,table (- (ash (array-underlying-widetag array) -2) 32))))) +(defun array-element-ctype (array) + ;; same as (SPECIFIER-TYPE (ARRAY-ELEMENT-TYPE ARRAY)) but more efficient + (widetag->type saetp-ctype)) (defun array-element-type (array) "Return the type of the elements of the array" - (let ((widetag (%other-pointer-widetag array)) - (table (load-time-value - (let ((table (make-array 256 :initial-element :invalid))) - (dotimes (i (length *specialized-array-element-type-properties*) table) - (let* ((saetp (aref *specialized-array-element-type-properties* i)) - (typecode (saetp-typecode saetp)) - (complex-typecode (saetp-complex-typecode saetp)) - (specifier (saetp-specifier saetp))) - (aver (typep specifier '(or list symbol))) - (setf (aref table typecode) specifier) - (when complex-typecode - (setf (aref table complex-typecode) specifier)))) - (setf (aref table simple-array-widetag) nil - (aref table complex-vector-widetag) nil - (aref table complex-array-widetag) nil) - table) - t))) - (let ((result (aref table widetag))) - (if result - (truly-the (or list symbol) result) - ;; (MAKE-ARRAY :ELEMENT-TYPE NIL) goes to this branch, but - ;; gets the right answer in the end - (with-array-data ((array array) (start) (end)) - (declare (ignore start end)) - (truly-the (or list symbol) (aref table (%other-pointer-widetag array)))))))) + (truly-the (or list symbol) (widetag->type saetp-specifier)))) (defun array-rank (array) "Return the number of dimensions of ARRAY." @@ -1106,22 +1125,14 @@ "Return T if the given ARRAY has a fill pointer, or NIL otherwise." (array-has-fill-pointer-p array)) -(defun fill-pointer-error (vector &optional arg) - (declare (optimize allow-non-returning-tail-call)) - (cond (arg - (aver (array-has-fill-pointer-p vector)) - (let ((max (%array-available-elements vector))) - (error 'simple-type-error - :datum arg - :expected-type (list 'integer 0 max) - :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)" - :format-arguments (list arg max)))) - (t - (error 'simple-type-error - :datum vector - :expected-type '(and vector (satisfies array-has-fill-pointer-p)) - :format-control "~S is not an array with a fill pointer." - :format-arguments (list vector))))) +(defun fill-pointer-error (vector) + (declare (optimize allow-non-returning-tail-call) + (optimize (sb-c::verify-arg-count 0))) + (error 'simple-type-error + :datum vector + :expected-type '(and vector (satisfies array-has-fill-pointer-p)) + :format-control "~S is not an array with a fill pointer." + :format-arguments (list vector))) (declaim (inline fill-pointer)) (defun fill-pointer (vector) @@ -1132,16 +1143,17 @@ (fill-pointer-error vector))) (defun %set-fill-pointer (vector new) - (declare (explicit-check) - (index new)) - (flet ((oops (x) - (fill-pointer-error vector x))) - (cond ((not (array-has-fill-pointer-p vector)) - (oops nil)) - ((> new (%array-available-elements vector)) - (oops new)) - (t - (setf (%array-fill-pointer vector) new))))) + (declare (explicit-check)) + (cond ((not (array-has-fill-pointer-p vector)) (fill-pointer-error vector)) + ((> (the index new) (%array-available-elements vector)) + (let ((max (%array-available-elements vector))) + (error 'simple-type-error + :datum new + :expected-type (list 'integer 0 max) + :format-control "The new fill pointer, ~S, is larger than the length of the vector (~S.)" + :format-arguments (list new max)))) + (t + (setf (%array-fill-pointer vector) new)))) ;;; FIXME: It'd probably make sense to use a MACROLET to share the ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro @@ -1163,33 +1175,19 @@ (setf (%array-fill-pointer array) (1+ fill-pointer)) fill-pointer)))) -;;; Widetags of FROM and TO should be equal -(defun copy-vector-data (from to start end n-bits-shift) - (declare (vector from to) - (index start end) - ((integer 0 7) n-bits-shift)) - (let ((from-length (length from))) - (cond ((simple-vector-p from) - (replace (truly-the simple-vector to) - (truly-the simple-vector from) - :start2 start :end2 end)) - ;; Vector sizes are double-word aligned and have zeros in - ;; the extra word so it's safe to copy when the boundaries - ;; are matching the whole vector. - ;; A more generic routine is left for another time, even if - ;; only handling aligned data since it will avoid consing - ;; floats or word bignums. - ((and (= start 0) - (= end from-length)) - (loop for i below (vector-length-in-words from-length n-bits-shift) - do (setf - (%vector-raw-bits to i) - (%vector-raw-bits from i)))) - (t - (replace to - from - :start2 start :end2 end))) - to)) +(defun !blt-copiers-cold-init (array) + (macrolet ((init () + `(progn + ,@(loop for saetp across *specialized-array-element-type-properties* + when (and (not (member (saetp-specifier saetp) '(t nil))) + (<= (saetp-n-bits saetp) n-word-bits)) + collect `(setf (svref array ,(ash (- (saetp-typecode saetp) 128) -2)) + #',(intern (format nil "UB~D-BASH-COPY" + (saetp-n-bits saetp)) + "SB-KERNEL")))))) + (init))) + +(defmacro blt-copier-for-widetag (x) `(aref +blt-copier-for-widetag+ (ash (- ,x 128) -2))) (defun extend-vector (vector min-extension) (declare (optimize speed) @@ -1207,14 +1205,24 @@ (let* ((widetag (%other-pointer-widetag old-data)) (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag)) (new-data - (allocate-vector-with-widetag widetag new-length n-bits-shift))) - (copy-vector-data old-data new-data old-start old-end n-bits-shift) + ;; FIXME: mark prefix of shadow bits assigned, suffix unassigned + (allocate-vector-with-widetag #+ubsan nil + widetag new-length n-bits-shift))) + ;; Copy the data + (if (= widetag simple-vector-widetag) ; the most common case + (replace (truly-the simple-vector new-data) ; transformed + (truly-the simple-vector old-data) + :start2 old-start :end2 old-end) + (let ((copier (blt-copier-for-widetag widetag))) + (if (functionp copier) + (funcall copier old-data old-start new-data 0 old-length) + (replace new-data old-data :start2 old-start :end2 old-end)))) (setf (%array-data vector) new-data (%array-available-elements vector) new-length (%array-fill-pointer vector) fill-pointer (%array-displacement vector) 0 - (%array-dimension vector 0) new-length (%array-displaced-p vector) nil) + (%set-array-dimension vector 0 new-length) vector)))) (defun vector-push-extend (new-element vector &optional min-extension) @@ -1248,210 +1256,179 @@ (defun adjust-array (array dimensions &key (element-type (array-element-type array) element-type-p) - (initial-element nil initial-element-p) - (initial-contents nil initial-contents-p) + (initial-element nil element-p) + (initial-contents nil contents-p) fill-pointer - displaced-to displaced-index-offset) + displaced-to (displaced-index-offset 0 offset-p)) "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." (when (invalid-array-p array) (invalid-array-error array)) - (binding* ((dimensions-rank (if (listp dimensions) - (length dimensions) - 1)) - (array-rank (array-rank array)) - (() - (unless (= dimensions-rank array-rank) - (error "The number of dimensions not equal to rank of array."))) - ((initialize initial-data) - (validate-array-initargs initial-element-p initial-element - initial-contents-p initial-contents - displaced-to)) - (widetag (array-underlying-widetag array))) - (cond ((and element-type-p - (/= (%vector-widetag-and-n-bits-shift element-type) - widetag)) - (error "The new element type, ~ - ~/sb-impl:print-type-specifier/, is incompatible ~ - with old type, ~/sb-impl:print-type-specifier/." - element-type (array-element-type array))) - ((and fill-pointer (/= array-rank 1)) - (error "Only vectors can have fill pointers.")) - ((and fill-pointer (not (array-has-fill-pointer-p array))) - ;; This case always struck me as odd. It seems like it might mean - ;; that the user asks that the array gain a fill-pointer if it didn't - ;; have one, yet CLHS is clear that the argument array must have a - ;; fill-pointer or else signal a type-error. - (fill-pointer-error array))) - (cond (initial-contents-p - ;; array former contents replaced by INITIAL-CONTENTS - (let* ((array-size (if (listp dimensions) - (apply #'* dimensions) - dimensions)) - (array-data (data-vector-from-inits - dimensions array-size element-type nil nil - initialize initial-data))) - (cond ((adjustable-array-p array) - (set-array-header array array-data array-size - (get-new-fill-pointer array array-size - fill-pointer) - 0 dimensions nil nil)) - ((array-header-p array) - ;; simple multidimensional or single dimensional array - (%make-array dimensions widetag - (aref %%simple-array-n-bits-shifts%% widetag) - :initial-contents initial-contents)) - (t - array-data)))) - (displaced-to - ;; We already established that no INITIAL-CONTENTS was supplied. - (when (/= (array-underlying-widetag displaced-to) widetag) - ;; See lp#1331299 again. Require exact match on upgraded type? - (error "can't displace an array of type ~ - ~/sb-impl:print-type-specifier/ into another ~ - of type ~/sb-impl:print-type-specifier/" - element-type (array-element-type displaced-to))) - (let ((displacement (or displaced-index-offset 0)) - (array-size (if (listp dimensions) - (apply #'* dimensions) - dimensions))) - (declare (fixnum displacement array-size)) - (if (< (the fixnum (array-total-size displaced-to)) - (the fixnum (+ displacement array-size))) - (error "The :DISPLACED-TO array is too small.")) - (if (adjustable-array-p array) - ;; None of the original contents appear in adjusted array. - (set-array-header array displaced-to array-size - (get-new-fill-pointer array array-size - fill-pointer) - displacement dimensions t nil) - ;; simple multidimensional or single dimensional array - (%make-array dimensions widetag - (aref %%simple-array-n-bits-shifts%% widetag) - :displaced-to displaced-to - :displaced-index-offset - displaced-index-offset)))) - ((= array-rank 1) - (let ((old-length (array-total-size array)) - (new-length (if (listp dimensions) - (car dimensions) - dimensions)) - new-data) - (declare (fixnum old-length new-length)) - (with-array-data ((old-data array) (old-start) - (old-end old-length)) - (cond ((or (and (array-header-p array) - (%array-displaced-p array)) - (< old-length new-length)) - (setf new-data - (data-vector-from-inits - dimensions new-length element-type - (%other-pointer-widetag old-data) nil - initialize initial-data)) - ;; Provide :END1 to avoid full call to LENGTH - ;; inside REPLACE. - (replace new-data old-data - :end1 new-length - :start2 old-start :end2 old-end)) - (t (setf new-data - (shrink-vector old-data new-length)))) - (if (adjustable-array-p array) - (set-array-header array new-data new-length - (get-new-fill-pointer array new-length - fill-pointer) - 0 dimensions nil nil) - new-data)))) - (t - (let ((old-length (%array-available-elements array)) - (new-length (apply #'* dimensions))) - (declare (fixnum old-length new-length)) - (with-array-data ((old-data array) (old-start) - (old-end old-length)) + (binding* + (((rank new-total-size) (rank-and-total-size-from-dims dimensions)) + (widetag + (let ((widetag (array-underlying-widetag array))) + (unless (= (array-rank array) rank) ; "drive-by" check of the rank + (error "Expected ~D new dimension~:P for array, but received ~D." + (array-rank array) rank)) + (if (or (not element-type-p) + ;; Quick pass if ELEMENT-TYPE is same as the element type based on widetag + (equal element-type (widetag->element-type widetag)) + (= (%vector-widetag-and-n-bits-shift element-type) widetag)) + widetag + (error "The new element type, ~/sb-impl:print-type-specifier/, is incompatible ~ + with old type, ~/sb-impl:print-type-specifier/." + element-type (array-element-type array))))) + (new-fill-pointer + (cond (fill-pointer + (unless (array-has-fill-pointer-p array) + (if (/= rank 1) + (error "Only vectors can have fill pointers.") + ;; I believe the sentence saying that this is an error pre-dates the removal + ;; of the restriction of calling ADJUST-ARRAY only on arrays that + ;; are actually adjustable. Making a new array should always work, + ;; so I think this may be a bug in the spec. + (fill-pointer-error array))) + (cond ((eq fill-pointer t) new-total-size) + ((<= fill-pointer new-total-size) fill-pointer) + (t (make-array-bad-fill-pointer fill-pointer new-total-size " new")))) + ((array-has-fill-pointer-p array) + ;; "consequences are unspecified if array is adjusted to a size smaller than its fill pointer" + (let ((old-fill-pointer (%array-fill-pointer array))) + (when (< new-total-size old-fill-pointer) + (error "can't adjust vector ~S to a size (~S) smaller than ~ + its current fill pointer (~S)" + array new-total-size old-fill-pointer)) + old-fill-pointer)))) + ((initialize initial-data) + (check-make-array-initargs t element-type new-total-size)) + (n-bits-shift (aref %%simple-array-n-bits-shifts%% widetag))) + + (cond + (displaced-to ; super easy - just repoint ARRAY to new data + (if (adjustable-array-p array) + (set-array-header array displaced-to new-total-size new-fill-pointer + displaced-index-offset dimensions t nil) + (%make-array dimensions widetag n-bits-shift + :displaced-to displaced-to + :displaced-index-offset displaced-index-offset))) + (contents-p ; array former contents replaced by INITIAL-CONTENTS + (let ((array-data (data-vector-from-inits dimensions new-total-size widetag n-bits-shift + initialize initial-data))) + (cond ((adjustable-array-p array) + (set-array-header array array-data new-total-size new-fill-pointer + 0 dimensions nil nil)) + ((array-header-p array) + ;; simple multidimensional array. + ;; fill-pointer vectors satisfy ADJUSTABLE-ARRAY-P (in SBCL, that is) + ;; and therefore are handled by the first stanza of the cond. + (%make-array dimensions widetag n-bits-shift + :initial-contents initial-contents)) + (t + array-data)))) + ((= rank 1) + (let ((old-length (array-total-size array))) + ;; Because ADJUST-ARRAY has to ignore any fill-pointer when + ;; copying from the old data, we can't just pass ARRAY as the + ;; second argument of REPLACE. + (with-array-data ((old-data array) (old-start) (old-end old-length)) + (let ((new-data + (if (and (= new-total-size old-length) + (not (and (array-header-p array) (%array-displaced-p array)))) + ;; if total size is unchanged, and it was not a displaced array, + ;; then this array owns the data and can retain it. + old-data + (let ((data (allocate-vector-with-widetag #+ubsan t + widetag new-total-size + n-bits-shift))) + (replace data old-data + :start1 0 :end1 new-total-size + :start2 old-start :end2 old-end) + (when (and element-p (> new-total-size old-length)) + (fill data initial-element :start old-length)) + data)))) + (if (adjustable-array-p array) + (set-array-header array new-data new-total-size new-fill-pointer + 0 dimensions nil nil) + new-data))))) + (t + (let ((old-total-size (%array-available-elements array))) + (with-array-data ((old-data array) (old-start) (old-end old-total-size)) (declare (ignore old-end)) (let ((new-data (if (or (and (array-header-p array) (%array-displaced-p array)) - (> new-length old-length) + (> new-total-size old-total-size) (not (adjustable-array-p array))) - (data-vector-from-inits - dimensions new-length - element-type - (%other-pointer-widetag old-data) nil - (if initial-element-p :initial-element) - initial-element) + (data-vector-from-inits dimensions new-total-size widetag + n-bits-shift initialize initial-data) old-data))) - (if (or (zerop old-length) (zerop new-length)) - (when initial-element-p (fill new-data initial-element)) + (if (or (zerop old-total-size) (zerop new-total-size)) + (when element-p (fill new-data initial-element)) (zap-array-data old-data (array-dimensions array) old-start - new-data dimensions new-length + new-data dimensions new-total-size element-type initial-element - initial-element-p)) + element-p)) (if (adjustable-array-p array) - (set-array-header array new-data new-length + (set-array-header array new-data new-total-size nil 0 dimensions nil nil) - (let ((new-array - (make-array-header - simple-array-widetag array-rank))) - (set-array-header new-array new-data new-length + (let ((new-array (make-array-header simple-array-widetag rank))) + (set-array-header new-array new-data new-total-size nil 0 dimensions nil t)))))))))) - -(defun get-new-fill-pointer (old-array new-array-size fill-pointer) - (declare (fixnum new-array-size)) - (typecase fill-pointer - (null - ;; "The consequences are unspecified if array is adjusted to a - ;; size smaller than its fill pointer ..." - (when (array-has-fill-pointer-p old-array) - (when (> (%array-fill-pointer old-array) new-array-size) - (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ - smaller than its fill pointer (~S)" - old-array new-array-size (fill-pointer old-array))) - (%array-fill-pointer old-array))) - ((eql t) - new-array-size) - (fixnum - (when (> fill-pointer new-array-size) - (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ - than the new length of the vector (~S)" - fill-pointer new-array-size)) - fill-pointer))) - ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH, ;;; which must be less than or equal to its current length. This can -;;; be called on vectors without a fill pointer but it is extremely -;;; dangerous to do so: shrinking the size of an object (as viewed by -;;; the gc) makes bounds checking unreliable in the face of interrupts -;;; or multi-threading. Call it only on provably local vectors. +;;; be called on vectors without a fill pointer but it is slightly +;;; dangerous to do so: shrinking the size of an object accessible +;;; to another thread could cause it to access an out-of-bounds element. +;;; GC should generally be fine no matter what happens, because it either +;;; reads the old length or the new length. If the old, and unboxed, +;;; the whole vector is skipped; if simple-vector, then at worst it reads +;;; the header word for a filler, which is a valid element (yup really!). +;;; If it reads the new length, then the next object is filler. (defun %shrink-vector (vector new-length) (declare (vector vector)) - (unless (array-header-p vector) - (macrolet ((frob (name &rest things) - `(etypecase ,name - ((simple-array nil (*)) (error 'nil-array-accessed-error)) - ,@(mapcar (lambda (thing) - (destructuring-bind (type-spec fill-value) - thing - `(,type-spec - (fill (truly-the ,type-spec ,name) - ,fill-value - :start new-length)))) - things)))) - ;; Set the 'tail' of the vector to the appropriate type of zero, - ;; "because in some cases we'll scavenge larger areas in one go, - ;; like groups of pages that had triggered the write barrier, or - ;; the whole static space" according to jsnell. - #.`(frob vector - ,@(map 'list - (lambda (saetp) - `((simple-array ,(saetp-specifier saetp) (*)) - ,(if (or (eq (saetp-specifier saetp) 'character) - #+sb-unicode - (eq (saetp-specifier saetp) 'base-char)) - '(code-char 0) - (saetp-initial-element-default saetp)))) - (remove-if-not - #'saetp-specifier - *specialized-array-element-type-properties*))))) + (unless (or (array-header-p vector) (typep vector '(simple-array nil (*)))) + (let ((old-length (length vector)) + (new-length new-length)) + (when (simple-base-string-p vector) + ;; We can blindly store the hidden #\null at NEW-LENGTH, but it would + ;; appear to be an out-of-bounds access if the length is not + ;; changing at all. i.e. while it's safe to always do a store, + ;; the length check has to be skipped. + (locally (declare (optimize (sb-c:insert-array-bounds-checks 0))) + (setf (schar vector new-length) (code-char 0))) + ;; Now treat both the old and new lengths as if they include + ;; the byte that holds the implicit string terminator. + (incf old-length) + (incf new-length)) + (let* ((n-bits-shift (aref %%simple-array-n-bits-shifts%% + (%other-pointer-widetag vector))) + (old-nwords (ceiling (ash old-length n-bits-shift) n-word-bits)) + (new-nwords (ceiling (ash new-length n-bits-shift) n-word-bits))) + ;; If we want to impose a constraint that unused bytes above the + ;; new length and below the physical end are 0, + ;; then now would be the time to enforce that. + (when (< new-nwords old-nwords) + (with-pinned-objects (vector) + ;; VECTOR-SAP is only for unboxed vectors. Use the vop directly. + (let ((data (%primitive vector-sap vector))) + ;; There is no requirement to zeroize memory corresponding + ;; to unused array elements. + ;; However, it's slightly nicer if the padding word (if present) is 0. + (when (oddp new-nwords) + (setf (sap-ref-word data (ash new-nwords word-shift)) 0)) + (let* ((aligned-old (align-up old-nwords 2)) + (aligned-new (align-up new-nwords 2))) + ;; Only if physically shrunk as determined by PRIMITIVE-OBJECT-SIZE + ;; will we need to (and have adequate room to) place a filler. + (when (< aligned-new aligned-old) + (let ((diff (- aligned-old aligned-new))) + ;; Certainly if the vector is unboxed it can't possibly matter + ;; if GC sees this bit pattern prior to setting the new length; + ;; but even for SIMPLE-VECTOR, it's OK, it turns out. + (setf (sap-ref-word data (ash aligned-new word-shift)) + (logior (ash (1- diff) n-widetag-bits) + filler-widetag))))))))))) ;; Only arrays have fill-pointers, but vectors have their length ;; parameter in the same place. (setf (%array-fill-pointer vector) new-length) @@ -1513,7 +1490,7 @@ (%array-available-elements from) 0 (%array-displaced-p from) (array-dimensions array)) (dotimes (i (%array-rank from)) - (setf (%array-dimension from i) 0))))))))) + (%set-array-dimension from i 0))))))))) (if newp (setf (%array-displaced-from array) nil) (%walk-displaced-array-backpointers array length)) @@ -1523,16 +1500,12 @@ (setf (%array-available-elements array) length) (cond (fill-pointer (setf (%array-fill-pointer array) fill-pointer) - (set-header-bits array sb-vm:+array-fill-pointer-p+)) + (logior-array-flags array +array-fill-pointer-p+)) (t (setf (%array-fill-pointer array) length) - (unset-header-bits array sb-vm:+array-fill-pointer-p+))) + (reset-array-flags array +array-fill-pointer-p+))) (setf (%array-displacement array) displacement) - (if (listp dimensions) - (dotimes (axis (array-rank array)) - (declare (type index axis)) - (setf (%array-dimension array axis) (pop dimensions))) - (setf (%array-dimension array 0) dimensions)) + (populate-dimensions array dimensions (array-rank array)) (setf (%array-displaced-p array) displacedp) array)) @@ -1697,6 +1670,17 @@ ;;; macro. CONCATENATE-FORMAT-P returns true, so then we want to know whether the ;;; result is a base-string which entails calling SB-KERNEL:SIMPLE-BASE-STRING-P ;;; which has no definition in the cross-compiler. (We could add one of course) + +;;; Bit array operations are allowed to leave arbitrary values in the +;;; trailing bits of the result. Examples: +;;; * (format t "~b~%" (%vector-raw-bits (bit-not #*1001) 0)) +;;; 1111111111111111111111111111111111111111111111111111111111110110 +;;; * (format t "~b~%" (%vector-raw-bits (bit-nor #*1001 #*1010) 0)) +;;; 1111111111111111111111111111111111111111111111111111111111110010 +;;; But because reading is more common than writing, it seems that a better +;;; technique might be to enforce an invariant that the last word contain 0 +;;; in all unused bits so that EQUAL and SXHASH become far simpler. + (macrolet ((def-bit-array-op (name function) `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array) ,(format nil @@ -1815,7 +1799,7 @@ ,@(ecase style (:call - `((!define-load-time-global ,table-name ,(sb-xc:make-array (1+ widetag-mask))) + `((define-load-time-global ,table-name ,(sb-xc:make-array (1+ widetag-mask))) ;; This SUBSTITUTE call happens ** after ** all the SETFs below it. ;; DEFGLOBAL's initial value is dumped by genesis as a vector filled @@ -1889,37 +1873,35 @@ (array-dimensions array))) array) -;;; Why is this needed for ARM and not x86 ??? -(defun allocate-vector (type length words) - (allocate-vector type length words)) - ;;; Horrible kludge for the "static-vectors" system ;;; which uses an internal symbol in SB-IMPL. (import '%vector-widetag-and-n-bits-shift 'sb-impl) (defun make-weak-vector (length &key (initial-contents nil contents-p) (initial-element nil element-p)) + (declare (index length)) (when (and element-p contents-p) (error "Can't specify both :INITIAL-ELEMENT and :INITIAL-CONTENTS")) ;; Explicitly compute a widetag with the weakness bit ORed in. - (let ((type (logior (ash vector-weak-flag sb-vm:n-widetag-bits) - sb-vm:simple-vector-widetag))) + (let ((type (logior (ash vector-weak-flag array-flags-position) simple-vector-widetag))) ;; These allocation calls are the transforms of MAKE-ARRAY for a vector with ;; the respective initializing keyword arg. This is badly OAOO-violating and ;; almost makes me want to cry, but not quite enough for me to improve it. (if contents-p (let ((contents-length (length initial-contents))) - (if (= (truly-the index length) contents-length) - (replace (truly-the simple-vector (allocate-vector type length length)) + (if (= length contents-length) + (replace (truly-the simple-vector + (allocate-vector #+ubsan nil type length length)) initial-contents) (error "~S has ~D elements, vector length is ~D." :initial-contents contents-length length))) (fill (truly-the simple-vector - (allocate-vector type (truly-the index length) length)) + (allocate-vector #+ubsan nil type length length)) ;; 0 is the usual default, but NIL makes more sense for weak vectors ;; as it is the value assigned to broken hearts. (if element-p initial-element nil))))) (defun weak-vector-p (x) (and (simple-vector-p x) - (eql (get-header-data x) vector-weak-flag))) + #+(or x86 x86-64) (test-header-bit x (ash vector-weak-flag array-flags-data-position)) + #-(or x86 x86-64) (logtest (get-header-data x) (ash vector-weak-flag array-flags-data-position)))) diff -Nru sbcl-2.1.1/src/code/backq.lisp sbcl-2.1.11/src/code/backq.lisp --- sbcl-2.1.1/src/code/backq.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/backq.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,7 +20,7 @@ (:copier nil)) (expr nil :read-only t) (kind nil :read-only t :type (member 0 1 2))) -#+sb-xc (declaim (freeze-type comma)) +(declaim (freeze-type comma)) (defconstant !+comma-dot+ 1) (defconstant !+comma-at+ 2) @@ -318,7 +318,7 @@ (set-macro-character #\, 'comma-charmacro nil rt)) ;;; This is a load-time effect, not compile-time, and *READTABLE* will have been ;;; reverted to the standard one, so be sure to assign into ours, not that. -#-sb-xc (!backq-cold-init sb-cold:*xc-readtable*) +#+sb-xc-host (!backq-cold-init sb-cold:*xc-readtable*) ;;; Since our backquote is installed on the host lisp, and since ;;; developers make mistakes with backquotes and commas too, let's diff -Nru sbcl-2.1.1/src/code/bignum.lisp sbcl-2.1.11/src/code/bignum.lisp --- sbcl-2.1.1/src/code/bignum.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/bignum.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -109,34 +109,112 @@ (defconstant all-ones-digit most-positive-word) -;;;; internal inline routines +#+bignum-assertions +(progn +(declaim (notinline %allocate-bignum)) +(defmacro with-bignum-shadow-bits ((bits object &optional length) &body body) + `(let ((b ,object)) + (with-pinned-objects (b) + (let ((,bits + (sb-sys:sap+ (sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address b)) + (- sb-vm:n-word-bytes sb-vm:other-pointer-lowtag)) + ;; shadow bits always start on a double-lispword boundary, + ;; so ensure that payload length looks like an odd number. + (ash (logior ,(or length `(%bignum-length b)) 1) + sb-vm:word-shift)))) + ,@body)))) -;;; %ALLOCATE-BIGNUM must zero all elements. (defun %allocate-bignum (length) (declare (type bignum-length length)) - (%allocate-bignum length)) + (declare (inline %allocate-bignum)) + (let ((bignum (%allocate-bignum length))) ; call the low-level allocator + (multiple-value-bind (nwords nbits) (floor length sb-vm:n-word-bits) + (with-bignum-shadow-bits (bit-base bignum length) + (dotimes (i nwords) + (setf (sap-ref-word bit-base 0) sb-ext:most-positive-word + bit-base (sap+ bit-base sb-vm:n-word-bytes))) + (when (plusp nbits) + (setf (sap-ref-word bit-base 0) + (#+little-endian shift-towards-start + #+big-endian shift-towards-end sb-ext:most-positive-word + (- nbits)))))) + (dotimes (i length) + (%%bignum-set bignum i (logior #+64-bit #xc0fefe0000 i))) + ;; If there is a padding word, then write junk in it, so we can assert that whenever + ;; bignum-set-length is used, the padding word (if present) was cleared. + (when (evenp length) (%%bignum-set bignum length #xdeadbeef)) + bignum)) + +(defun index-out-of-bounds (bignum i) + (error "out-of-bounds bignum set @ ~x[~d], len=~d~%" + (get-lisp-obj-address bignum) i (%bignum-length bignum))) -;;; Extract the length of the bignum. -(defun %bignum-length (bignum) - (declare (type bignum bignum)) - (%bignum-length bignum)) - -;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs -;;; to be able to return the digit somewhere no one looks for real objects. -(defun %bignum-ref (bignum i) - (declare (type bignum bignum) - (type bignum-index i)) - (%bignum-ref bignum i)) +(declaim (inline %bignum-set)) (defun %bignum-set (bignum i value) (declare (type bignum bignum) (type bignum-index i) (type bignum-element-type value)) - (%bignum-set bignum i value)) + (cond ((< i (%bignum-length bignum)) + (with-bignum-shadow-bits (bit-base bignum) + (multiple-value-bind (word-index bit-index) (floor i sb-vm:n-word-bits) + (let ((sap (sap+ bit-base (* word-index sb-vm:n-word-bytes)))) + (setf (sap-ref-word sap 0) + (logandc2 (sap-ref-word sap 0) (ash 1 bit-index)))))) + (%%bignum-set bignum i value)) + (t + (index-out-of-bounds bignum i))) + (values)) -;;; Return T if digit is positive, or NIL if negative. -(defun %digit-0-or-plusp (digit) - (declare (type bignum-element-type digit)) - (not (logbitp (1- digit-size) digit))) +(defun bignum-ref-trap (bignum i) + ;; This error might happen too early in cold-init to report it normally + (alien-funcall (extern-alien "printf" (function void system-area-pointer unsigned unsigned)) + (vector-sap #.(format nil "Element %d of bignum %p was never written~%")) + i (get-lisp-obj-address bignum)) + (alien-funcall (extern-alien "ldb_monitor" (function void))) + 0) + +(declaim (inline %bignum-ref)) +(defun %bignum-ref (bignum i) + (declare (type bignum bignum) + (type bignum-index i)) + ;; We don't need to check %BIGNUM-LENGTH because the shadow bit won't be on + ;; presuming that we only care to detct "small" off-by-1 errors, + ;; and not egregious buffer overrun errors. + (multiple-value-bind (word-index bit-index) (floor i sb-vm:n-word-bits) + (with-bignum-shadow-bits (bit-base bignum) + (let ((sap (sap+ bit-base (* word-index sb-vm:n-word-bytes)))) + (if (logbitp bit-index (sap-ref-word sap 0)) ; word was never assigned + (truly-the sb-vm:word (bignum-ref-trap bignum i)) + (sap-ref-word (int-sap (get-lisp-obj-address bignum)) + (- (ash (+ i sb-vm:bignum-digits-offset) sb-vm:word-shift) + sb-vm:other-pointer-lowtag))))))) + +(defun aver-zeroed-from-index (bignum index) + (with-pinned-objects (bignum) + (let* ((physical-start (sap+ (int-sap (get-lisp-obj-address bignum)) + (- sb-vm:other-pointer-lowtag))) + (physlen-bytes (ash (+ (* (%bignum-length bignum) 2) 2) sb-vm:word-shift)) + (physical-end (sap+ physical-start physlen-bytes)) + (word-ptr (sap+ physical-start (ash (1+ index) sb-vm:word-shift)))) + (loop while (sb-sys:sap< word-ptr physical-end) + do (unless (= (sap-ref-word word-ptr 0) 0) + (alien-funcall (extern-alien "printf" + (function void system-area-pointer unsigned unsigned)) + (vector-sap #.(format nil "set-length %p,%d not properly zeroed~%")) + (get-lisp-obj-address bignum) index) + (alien-funcall (extern-alien "ldb_monitor" (function void)))) + (setq word-ptr (sap+ word-ptr 8)))))) +) + +;;; DO NOT ASSUME THAT LOW-LEVEL ALLOCATOR PREZEROES THE MEMORY +(defmacro alloc-zeroing (length) + `(let* ((l ,length) (new (%allocate-bignum l))) + (dotimes (i l new) + (setf (%bignum-ref new i) 0)))) +(defmacro alloc-zeroing-below (length end) + `(let ((new (%allocate-bignum ,length))) + (dotimes (i ,end new) + (setf (%bignum-ref new i) 0)))) (declaim (inline %bignum-0-or-plusp)) (defun %bignum-0-or-plusp (bignum len) @@ -144,48 +222,10 @@ (type bignum-length len)) (%digit-0-or-plusp (%bignum-ref bignum (1- len)))) -;;; This should be in assembler, and should not cons intermediate -;;; results. It returns a bignum digit and a carry resulting from adding -;;; together a, b, and an incoming carry. -(defun %add-with-carry (a b carry) - (declare (type bignum-element-type a b) - (type (mod 2) carry)) - (%add-with-carry a b carry)) - -;;; This should be in assembler, and should not cons intermediate -;;; results. It returns a bignum digit and a borrow resulting from -;;; subtracting b from a, and subtracting a possible incoming borrow. -;;; -;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1. -(defun %subtract-with-borrow (a b borrow) - (declare (type bignum-element-type a b) - (type (mod 2) borrow)) - (%subtract-with-borrow a b borrow)) - -;;; Multiply two digit-size numbers, returning a 2*digit-size result -;;; split into two digit-size quantities. -(defun %multiply (x y) - (declare (type bignum-element-type x y)) - (%multiply x y)) - -;;; This multiplies x-digit and y-digit, producing high and low digits -;;; manifesting the result. Then it adds the low digit, res-digit, and -;;; carry-in-digit. Any carries (note, you still have to add two digits -;;; at a time possibly producing two carries) from adding these three -;;; digits get added to the high digit from the multiply, producing the -;;; next carry digit. Res-digit is optional since two uses of this -;;; primitive multiplies a single digit bignum by a multiple digit -;;; bignum, and in this situation there is no need for a result buffer -;;; accumulating partial results which is where the res-digit comes -;;; from. -(defun %multiply-and-add (x-digit y-digit carry-in-digit - &optional (res-digit 0)) - (declare (type bignum-element-type x-digit y-digit res-digit carry-in-digit)) - (%multiply-and-add x-digit y-digit carry-in-digit res-digit)) - -(defun %lognot (digit) - (declare (type bignum-element-type digit)) - (%lognot digit)) +(declaim (inline bignum-plus-p)) +(defun bignum-plus-p (bignum) + (declare (type bignum bignum)) + (%bignum-0-or-plusp bignum (%bignum-length bignum))) ;;; Each of these does the digit-size unsigned op. (declaim (inline %logand %logior %logxor)) @@ -201,48 +241,11 @@ ;;; This takes a fixnum and sets it up as an unsigned digit-size ;;; quantity. +;;; The stub function is needed for constant-folding, or where vops don't exist (defun %fixnum-to-digit (x) (declare (fixnum x)) - (logand x (1- (ash 1 digit-size)))) - -;;; This takes three digits and returns the FLOOR'ed result of -;;; dividing the first two as a 2*digit-size integer by the third. -(defun %bigfloor (a b c) - (%bigfloor a b c)) - -;;; Convert the digit to a regular integer assuming that the digit is signed. -(defun %fixnum-digit-with-correct-sign (digit) - (declare (type bignum-element-type digit)) - (if (logbitp (1- digit-size) digit) - (logior digit (ash -1 digit-size)) - digit)) - -;;; Do an arithmetic shift right of data even though bignum-element-type is -;;; unsigned. -(defun %ashr (data count) - (declare (type bignum-element-type data) - (type (mod #.sb-vm:n-word-bits) count)) - (%ashr data count)) - -;;; This takes a digit-size quantity and shifts it to the left, -;;; returning a digit-size quantity. -(defun %ashl (data count) - (declare (type bignum-element-type data) - (type (mod #.sb-vm:n-word-bits) count)) - (%ashl data count)) - -;;; Do an unsigned (logical) right shift of a digit by Count. -(defun %digit-logical-shift-right (data count) - (declare (type bignum-element-type data) - (type (mod #.sb-vm:n-word-bits) count)) - (%digit-logical-shift-right data count)) - -;;; Change the length of bignum to be newlen. Newlen must be the same or -;;; smaller than the old length, and any elements beyond newlen must be zeroed. -(defun %bignum-set-length (bignum newlen) - (declare (type bignum bignum) - (type bignum-length newlen)) - (%bignum-set-length bignum newlen)) + #+(or arm arm64) (logand x (1- (ash 1 digit-size))) ; missing the vops + #-(or arm arm64) (%fixnum-to-digit x)) ;;; This returns 0 or "-1" depending on whether the bignum is positive. This ;;; is suitable for infinite sign extension to complete additions, @@ -254,13 +257,70 @@ (type bignum-length len)) (%ashr (%bignum-ref bignum (1- len)) (1- digit-size))) -(declaim (inline bignum-plus-p)) -(defun bignum-plus-p (bignum) - (declare (type bignum bignum)) - (%bignum-0-or-plusp bignum (%bignum-length bignum))) +(declaim (inline (setf %bignum-ref))) +(defun (setf %bignum-ref) (val bignum index) + (%bignum-set bignum index val) ; valueless + val) (declaim (optimize (speed 3) (safety 0))) +;;;; general utilities + +;;; Internal in-place operations use this to fixup remaining digits in the +;;; incoming data, such as in-place shifting. This is basically the same as +;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer +;;; instead of shrinking the bignum. +(declaim (maybe-inline %normalize-bignum-buffer)) +(defun %normalize-bignum-buffer (result len) + (declare (type bignum result) + (type bignum-length len)) + (unless (= len 1) + (do ((next-digit (%bignum-ref result (- len 2)) + (%bignum-ref result (- len 2))) + (sign-digit (%bignum-ref result (1- len)) next-digit)) + ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size)))))) + (decf len) + (setf (%bignum-ref result len) 0) + (when (= len 1) (return)))) + len) + +;; Prior to calling %bignum-set-length we have to ensure that if the physical length +;; decreases, then final word that may never have been written does not contain junk. +(defmacro clear-padding-word (bignum oldlen newlen) + (declare (ignorable newlen)) + `(progn + (when (evenp ,oldlen) + (#+bignum-assertions %%bignum-set #-bignum-assertions %bignum-set ,bignum ,oldlen 0)) + #+bignum-assertions (aver-zeroed-from-index ,bignum ,newlen))) + +;;; This drops the last digit if it is unnecessary sign information. It repeats +;;; this as needed, possibly ending with a fixnum. If the resulting length from +;;; shrinking is one, see whether our one word is a fixnum. Shift the possible +;;; fixnum bits completely out of the word, and compare this with shifting the +;;; sign bit all the way through. If the bits are all 1's or 0's in both words, +;;; then there are just sign bits between the fixnum bits and the sign bit. If +;;; we do have a fixnum, shift it over for the two low-tag bits. +(defun %normalize-bignum (result len) + (declare (type bignum result) + (type bignum-length len) + (muffle-conditions compiler-note) + #-sb-fluid (inline %normalize-bignum-buffer)) + #+bignum-assertions (aver (= (%bignum-length result) len)) + (let ((newlen (%normalize-bignum-buffer result len))) + (declare (type bignum-length newlen)) + (unless (= newlen len) + ;; If the old length was even, then there is a word which was never accessed + ;; and may contains random bits. Clear it to avoid a crash in GC. + (clear-padding-word result len newlen) + (%bignum-set-length result newlen)) + (if (= newlen 1) + (let ((digit (%bignum-ref result 0))) + (if (= (%ashr digit sb-vm:n-positive-fixnum-bits) + (%ashr digit (1- digit-size))) + (%fixnum-digit-with-correct-sign digit) + result)) + result))) + ;;;; addition (defun add-bignums (a b) @@ -372,7 +432,7 @@ (len-a (%bignum-length a)) (len-b (%bignum-length b)) (len-res (+ len-a len-b)) - (res (%allocate-bignum len-res)) + (res (alloc-zeroing len-res)) (negate-res (not (eq a-plusp b-plusp)))) (declare (type bignum-length len-a len-b len-res)) (dotimes (i len-a) @@ -443,50 +503,53 @@ ;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS -(defmacro bignum-replace (dest src - &key - (start1 '0) - end1 - (start2 '0) - end2 - from-end) - (once-only ((n-dest dest) - (n-src src)) - (with-unique-names (n-start1 n-end1 n-start2 n-end2 i1 i2) - (let ((end1 (or end1 `(%bignum-length ,n-dest))) - (end2 (or end2 `(%bignum-length ,n-src)))) - (if from-end - `(let ((,n-start1 ,start1) - (,n-start2 ,start2)) - (do ((,i1 (1- ,end1) (1- ,i1)) - (,i2 (1- ,end2) (1- ,i2))) - ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2))) - (declare (fixnum ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2)))) - (if (eql start1 start2) - `(let ((,n-end1 (min ,end1 ,end2))) - (do ((,i1 ,start1 (1+ ,i1))) - ((>= ,i1 ,n-end1)) - (declare (type bignum-index ,i1)) - (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i1)))) - `(let ((,n-end1 ,end1) - (,n-end2 ,end2)) - (do ((,i1 ,start1 (1+ ,i1)) - (,i2 ,start2 (1+ ,i2))) - ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2))) - (declare (type bignum-index ,i1 ,i2)) - (%bignum-set ,n-dest ,i1 (%bignum-ref ,n-src ,i2)))))))))) +#-bignum-assertions +(defmacro bignum-replace (dest src &key (start1 0) (end1 `(%bignum-length ,dest)) + (start2 0) (end2 `(%bignum-length ,src))) + (flet ((@ (obj index) + `(sap+ (sap+ (int-sap (get-lisp-obj-address ,obj)) (ash ,index sb-vm:word-shift)) + (- (ash sb-vm:bignum-digits-offset sb-vm:word-shift) + sb-vm:other-pointer-lowtag)))) + `(let ((count ,(if (and (eql start1 0) (eql start2 0)) + `(min ,end1 ,end2) + `(min (- ,end1 ,start1) (- ,end2 ,start2))))) + (cond ((= count 2) ; COUNT is almost always 2 + (setf (%bignum-ref ,dest ,start1) (%bignum-ref ,src ,start2) + (%bignum-ref ,dest (1+ ,start1)) (%bignum-ref ,src (1+ ,start2)))) + ((= count 1) + (setf (%bignum-ref ,dest ,start1) (%bignum-ref ,src ,start2))) + ((> count 0) + (with-alien ((replace (function system-area-pointer system-area-pointer + system-area-pointer sb-unix::size-t) + :extern ,(if (eq dest src) "memmove" "memcpy"))) + (with-pinned-objects (,dest ,src) + (alien-funcall replace ,(@ dest start1) ,(@ src start2) + (ash count sb-vm:word-shift))))))))) +#+bignum-assertions +(progn +(defmacro bignum-replace (dest src &key (start1 '0) (end1 `(%bignum-length ,dest)) + (start2 '0) (end2 `(%bignum-length ,src))) + `(bignum-replace-impl ,dest ,start1 ,end1 + ,src ,start2 ,end2)) + +(defun bignum-replace-impl (dest start1 end1 src start2 end2) + (do ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((or (>= i1 end1) + (>= i2 end2))) + (declare (type bignum-index i1 i2)) + (%bignum-set dest i1 (%bignum-ref src i2))))) (defmacro with-bignum-buffers (specs &body body) "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*" (collect ((binds) (inits)) (dolist (spec specs) (let ((name (first spec)) - (size (second spec))) + (size (second spec)) + (init (third spec))) (binds `(,name (%allocate-bignum ,size))) - (let ((init (third spec))) - (when init - (inits `(bignum-replace ,name ,init)))))) + (when init + (inits `(bignum-replace ,name ,init))))) `(let* ,(binds) ,@(inits) ,@body))) @@ -496,8 +559,8 @@ ;; The asserts in the GCD implementation are way too expensive to ;; check in normal use, and are disabled here. (defmacro gcd-assert (&rest args) - (declare (ignore args)) - #+sb-bignum-assertions `(assert ,@args)) + (declare (ignorable args)) + #+bignum-assertions `(assert ,@args)) ;; We'll be doing a lot of modular arithmetic. (defmacro modularly (form) `(logand all-ones-digit ,form)) @@ -624,10 +687,10 @@ (d2 (modularly -1))) (declare (type word n1 d1 n2 d2)) (loop while (> n2 (expt 2 (truncate digit-size 2))) do - (loop for i of-type (mod #.sb-vm:n-word-bits) + (loop for i of-type fixnum downfrom (- (integer-length n1) (integer-length n2)) while (>= n1 n2) do - (when (>= n1 (modularly (ash n2 i))) + (when (>= n1 (modularly (ash n2 (truly-the (mod #.sb-vm:n-word-bits) i)))) (psetf n1 (modularly (- n1 (modularly (ash n2 i)))) d1 (modularly (- d1 (modularly (ash d2 i))))))) (psetf n1 n2 @@ -746,7 +809,12 @@ (- (copy-bignum tmp1 tmp1-len) (copy-bignum tmp2 tmp2-len))))) (bignum-abs-buffer u u-len) - (gcd-assert (zerop (modularly u))))) + ;; This assertion is strange, because we're trying to assert on + ;; the least significant word of U, but MODULARLY might do a full call + ;; to TWO-ARG-LOGAND, and it it does, that fails, because not all + ;; words of U are set. And rightly so- they're set only below U-LEN. + #+ppc (gcd-assert (zerop (modularly (copy-bignum u u-len)))) + #-ppc (gcd-assert (zerop (modularly u))))) (setf u-len (make-gcd-bignum-odd u u-len)) (rotatef u v) (rotatef u-len v-len)) @@ -904,7 +972,14 @@ (%add-with-carry (%lognot (%sign-digit x len-x)) 0 carry))) (if fully-normalize (%normalize-bignum res len-res) - (%mostly-normalize-bignum res len-res)))) + ;; This drops the last digit if it is unnecessary sign information. It + ;; repeats this as needed, possibly ending with a fixnum magnitude but never + ;; returning a fixnum. + (locally (declare (inline %normalize-bignum-buffer)) + (let ((newlen (%normalize-bignum-buffer res len-res))) + (clear-padding-word res len-res newlen) + (%bignum-set-length res newlen)) + res)))) ;;; This assumes bignum is positive; that is, the result of negating it will ;;; stay in the provided allocated bignum. @@ -1053,10 +1128,9 @@ (defun bignum-ashift-left-digits (bignum bignum-len digits) (declare (type bignum-length bignum-len digits)) (let* ((res-len (+ bignum-len digits)) - (res (%allocate-bignum res-len))) + (res (alloc-zeroing-below res-len digits))) (declare (type bignum-length res-len)) - (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len - :from-end t) + (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len) res)) ;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. @@ -1074,7 +1148,7 @@ (type (mod #.digit-size) n-bits)) (let* ((remaining-bits (- digit-size n-bits)) (res-len-1 (1- res-len)) - (res (or res (%allocate-bignum res-len)))) + (res (or res (alloc-zeroing-below res-len digits)))) (declare (type bignum-length res-len res-len-1)) (do ((i 0 (1+ i)) (j (1+ digits) (1+ j))) @@ -1111,12 +1185,12 @@ (/= left-half 0))) (length (+ right-zero-digits (if left-half-p 2 1))) - (result (%allocate-bignum length))) + (result (alloc-zeroing-below length right-zero-digits))) (setf (%bignum-ref result right-zero-digits) right-half) (when left-half-p (setf (%bignum-ref result (1+ right-zero-digits)) (ldb (byte digit-size 0) left-half))) - result))) + result))) ;;;; relational operators @@ -1727,6 +1801,8 @@ (declare (type bignum-length len-q) (type bignum-index k i i-1 i-2 low-x-digit) (type bignum-element-type y1 y2)) + ;; DO NOT ASSUME THAT %ALLOCATE-BIGNUM PREZEROS + (setf (%bignum-ref q len-q) 0) (loop (setf (%bignum-ref q k) (try-bignum-truncate-guess @@ -1868,8 +1944,10 @@ (values 0 res))) (t (let ((len-x+1 (1+ len-x))) - (setf truncate-x (%allocate-bignum len-x+1)) - (setf truncate-y (%allocate-bignum (1+ len-y))) + ;; TODO: someone who understands this algorithm could probably figure out + ;; whether these allocations can prezero fewer words. + (setf truncate-x (alloc-zeroing len-x+1)) + (setf truncate-y (alloc-zeroing (1+ len-y))) (let ((y-shift (shift-y-for-truncate y))) (shift-and-store-truncate-buffers x len-x y len-y y-shift) @@ -1906,64 +1984,6 @@ rem (%normalize-bignum rem (%bignum-length rem)))))))))) -;;;; general utilities - -;;; Internal in-place operations use this to fixup remaining digits in the -;;; incoming data, such as in-place shifting. This is basically the same as -;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer -;;; instead of shrinking the bignum. -(declaim (maybe-inline %normalize-bignum-buffer)) -(defun %normalize-bignum-buffer (result len) - (declare (type bignum result) - (type bignum-length len)) - (unless (= len 1) - (do ((next-digit (%bignum-ref result (- len 2)) - (%bignum-ref result (- len 2))) - (sign-digit (%bignum-ref result (1- len)) next-digit)) - ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size)))))) - (decf len) - (setf (%bignum-ref result len) 0) - (when (= len 1) - (return)))) - len) - -;;; This drops the last digit if it is unnecessary sign information. It repeats -;;; this as needed, possibly ending with a fixnum. If the resulting length from -;;; shrinking is one, see whether our one word is a fixnum. Shift the possible -;;; fixnum bits completely out of the word, and compare this with shifting the -;;; sign bit all the way through. If the bits are all 1's or 0's in both words, -;;; then there are just sign bits between the fixnum bits and the sign bit. If -;;; we do have a fixnum, shift it over for the two low-tag bits. -(defun %normalize-bignum (result len) - (declare (type bignum result) - (type bignum-length len) - (muffle-conditions compiler-note) - #-sb-fluid (inline %normalize-bignum-buffer)) - (let ((newlen (%normalize-bignum-buffer result len))) - (declare (type bignum-length newlen)) - (unless (= newlen len) - (%bignum-set-length result newlen)) - (if (= newlen 1) - (let ((digit (%bignum-ref result 0))) - (if (= (%ashr digit sb-vm:n-positive-fixnum-bits) - (%ashr digit (1- digit-size))) - (%fixnum-digit-with-correct-sign digit) - result)) - result))) - -;;; This drops the last digit if it is unnecessary sign information. It -;;; repeats this as needed, possibly ending with a fixnum magnitude but never -;;; returning a fixnum. -(defun %mostly-normalize-bignum (result len) - (declare (type bignum result) - (type bignum-length len) - #-sb-fluid (inline %normalize-bignum-buffer)) - (let ((newlen (%normalize-bignum-buffer result len))) - (declare (type bignum-length newlen)) - (unless (= newlen len) - (%bignum-set-length result newlen)) - result)) - ;;;; hashing ;;; the bignum case of the SXHASH function @@ -2005,3 +2025,21 @@ (return-from bignum-lower-bits-zero-p nil))) (zerop (logand (1- (ash 1 n-bits-partial-digit)) (%bignum-ref bignum n-full-digits)))))) + +#| +(let (code-components) + (do-symbols (s 'sb-bignum) + (when (and (fboundp s) + (eq (symbol-package s) (find-package "SB-BIGNUM"))) + (pushnew (sb-kernel:fun-code-header (symbol-function s)) code-components))) + (let ((tot-size 0) (tot-consts 0)) + (dolist (code code-components) + (let ((nconsts (sb-kernel:code-header-words code)) + (size (sb-ext:primitive-object-size code))) + (incf tot-size size) + (incf tot-consts nconsts) + (format t "~5d ~3d ~a~%" size nconsts code))) + (format t "~5d ~3d~%" tot-size tot-consts))) +; => 32208 565 ; without block-compile +; => 23184 214 ; with block-compile in normal self-build +|# diff -Nru sbcl-2.1.1/src/code/bignum-random.lisp sbcl-2.1.11/src/code/bignum-random.lisp --- sbcl-2.1.1/src/code/bignum-random.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/bignum-random.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -43,6 +43,9 @@ (let* ((n-total-bits (+ 1 n-random-chunk-bits bit-count)) ; sign bit (length (ceiling n-total-bits digit-size)) (bignum (%allocate-bignum length))) + ;; DO NOT ASSUME THAT %ALLOCATE-BIGNUM PREZEROS + ;; [See example in MAKE-RANDOM-BIGNUM] + (setf (%bignum-ref bignum (1- length)) 0) (multiple-value-bind (n-random-digits n-random-bits) (floor bit-count digit-size) (declare (type bignum-length n-random-digits)) @@ -72,6 +75,11 @@ (length (ceiling n-total-bits digit-size)) (bignum (%allocate-bignum length))) (declare (type bignum-length length)) + ;; DO NOT ASSUME THAT %ALLOCATE-BIGNUM PREZEROS + ;; Consider: n-bits = 64 -> n-total-bits = 65 -> length = 2 + ;; and n-digits = 1, n-bits-partial-digit = 0 + ;; so DOTIMES executes exactly once, leaving the final word untouched. + (setf (%bignum-ref bignum (1- length)) 0) (multiple-value-bind (n-digits n-bits-partial-digit) (floor n-bits digit-size) (declare (type bignum-length n-digits)) diff -Nru sbcl-2.1.1/src/code/bit-bash.lisp sbcl-2.1.11/src/code/bit-bash.lisp --- sbcl-2.1.1/src/code/bit-bash.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/bit-bash.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -10,72 +10,9 @@ ;;;; files for more information. (in-package "SB-VM") - -;;;; types - -(eval-when (:compile-toplevel) - ;; This DEFTYPE must be macroexpanded directly by the host, as it is referenced by - ;; a defun that is also within an eval-when. Writing the eval-when situations as - ;; (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL) isn't good enough, because that expands only - ;; by the cross-compiler. In reality this type isn't technically helpful to have, - ;; because both its uses are in an LDB expression whose type is trivially derivable. - ;; However I'm keeping it as a minimal example of a tricky cross-compilation issue. - (deftype bit-offset () `(integer 0 (,n-word-bits)))) -(deftype bit-offset () `(integer 0 (,n-word-bits))) ;;;; support routines -;;; A particular implementation must offer either VOPs to translate -;;; these, or DEFTRANSFORMs to convert them into something supported -;;; by the architecture. -(macrolet ((def (name &rest args) - `(defun ,name ,args - (,name ,@args)))) - (def word-logical-not x) - (def word-logical-and x y) - (def word-logical-or x y) - (def word-logical-xor x y) - (def word-logical-nor x y) - (def word-logical-eqv x y) - (def word-logical-nand x y) - (def word-logical-andc1 x y) - (def word-logical-andc2 x y) - (def word-logical-orc1 x y) - (def word-logical-orc2 x y)) - -;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits -;;; at the "end" and removing bits from the "start". On big-endian -;;; machines this is a left-shift and on little-endian machines this -;;; is a right-shift. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun shift-towards-start (number countoid) - (declare (type word number) (fixnum countoid)) - (let ((count (ldb (byte (1- (integer-length n-word-bits)) 0) countoid))) - (declare (type bit-offset count)) - (if (zerop count) - number - (ecase sb-c:*backend-byte-order* - (:big-endian - (ash (ldb (byte (- n-word-bits count) 0) number) count)) - (:little-endian - (ash number (- count)))))))) - -;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and -;;; removing bits from the "end". On big-endian machines this is a -;;; right-shift and on little-endian machines this is a left-shift. -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun shift-towards-end (number count) - (declare (type word number) (fixnum count)) - (let ((count (ldb (byte (1- (integer-length n-word-bits)) 0) count))) - (declare (type bit-offset count)) - (if (zerop count) - number - (ecase sb-c:*backend-byte-order* - (:big-endian - (ash number (- count))) - (:little-endian - (ash (ldb (byte (- n-word-bits count) 0) number) count))))))) - (declaim (inline start-mask end-mask)) ;;; Produce a mask that contains 1's for the COUNT "start" bits and @@ -94,56 +31,193 @@ (declare (fixnum count)) (shift-towards-end most-positive-word (- count))) -(declaim (inline word-sap-ref %set-word-sap-ref)) -(defun word-sap-ref (sap offset) - (declare (type system-area-pointer sap) - (type index offset) - (muffle-conditions compiler-note) ; "unsigned word to integer coercion" - (optimize (speed 3) (safety 0))) - (sap-ref-word sap (the index (ash offset word-shift)))) -(defun %set-word-sap-ref (sap offset value) - (declare (type system-area-pointer sap) - (type index offset) - (type word value) - (muffle-conditions compiler-note) ; "unsigned word to integer coercion" - (optimize (speed 3) (safety 0))) - (setf (sap-ref-word sap (the index (ash offset word-shift))) - value)) - ;;; the actual bashers and common uses of same -;;; This is a little ugly. Fixing bug 188 would bring the ability to -;;; wrap a MACROLET or something similar around this whole thing would -;;; make things significantly less ugly. --njf, 2005-02-23 -;;; -;;; Well, it turns out that we *could* wrap a MACROLET around this, -;;; but it's quite ugly in a different way: when you write -;;; (MACROLET ((GENERATOR () `(DEFUN F (X) ,@(INSANITY ...))) (GENERATOR))) -;;; and then view the inline expansion of F, you'll see it has actually -;;; captured the entirety of the MACROLET that surrounded it. -;;; With respect to building SBCL, this means, among other things, that -;;; it'd hang onto all the "!" symbols that would otherwise disappear, -;;; as well as kilobytes of completely useless s-expressions. (eval-when (:compile-toplevel :load-toplevel :execute) - -;;; Align the SAP to a word boundary, and update the offset accordingly. -(defmacro !define-sap-fixer (bitsize) - (let ((name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize)))) - `(progn - (declaim (inline ,name)) - (defun ,name (sap offset) - (declare (type system-area-pointer sap) - (type index offset) - (values system-area-pointer index)) - (let ((address (sap-int sap)) - (word-mask (1- (ash 1 word-shift)))) - (values (int-sap (word-logical-andc2 address word-mask)) - (+ ,(ecase bitsize - ((1 2 4) `(* (logand address word-mask) - (/ n-byte-bits ,bitsize))) - ((8 16 32 64) '(logand address word-mask))) - offset))))))) + (defconstant min-bytes-c-call-threshold + ;; mostly just guessing here + #+(or x86 x86-64 ppc ppc64) 128 + #-(or x86 x86-64 ppc ppc64) 256)) + +(defmacro verify-src/dst-bits-per-elt (source destination expect-bits-per-element) + (declare (ignorable source destination expect-bits-per-element)) + #+(and sb-devel (not sb-devel-no-errors)) + `(let ((src-bits-per-element + (ash 1 (aref %%simple-array-n-bits-shifts%% + (%other-pointer-widetag ,source)))) + (dst-bits-per-element + (ash 1 (aref %%simple-array-n-bits-shifts%% + (%other-pointer-widetag ,destination))))) + (when (or (/= src-bits-per-element ,expect-bits-per-element) + (/= dst-bits-per-element ,expect-bits-per-element)) + ;; Why enforce this: because since the arrays are lisp objects + ;; maybe we can be clever "somehow" (I'm not sure how) + ;; and/or maybe we have to unpoison the memory for #+ubsan. + ;; Whereas BYTE-BLT takes SAPs (and/or arrays) and so it has to + ;; be more strictly like memmove(). Because it is exactly that. + (error "Misuse of bash-copy: bits-per-elt=~D but src=~d and dst=~d" + ,expect-bits-per-element src-bits-per-element dst-bits-per-element)))) + +;;; 1, 2, 4, and 8 bytes per element can be handled with memmove() +;;; or, if it's easy enough, a loop over VECTOR-RAW-BITS. +(defmacro define-byte-blt-copier + (bytes-per-element + &aux (bits-per-element (* bytes-per-element 8)) + (vtype `(simple-array (unsigned-byte ,bits-per-element) (*))) + (elements-per-word (/ n-word-bytes bytes-per-element)) + (always-call-out-p ; memmove() is _always_ asymptotically faster than this + ;; code, which can't make any use of vectorization that C libraries + ;; typically do. It's a question of the overhead of a C call. + `(>= nelements ,(/ min-bytes-c-call-threshold bytes-per-element)))) + (flet ((backward-p () + ;; Iterate backwards if there is overlap and byte transfer is toward higher + ;; addresses. Technically (> dst-start src-start) is a necessary + ;; but not sufficient condition for overlap, but it's fine. + '(and (eq src dst) (> dst-start src-start))) + (down () + ;; We could reduce the number of loop variables by 1 by computing + ;; the distance between src-start and dst-start, and adding it in + ;; to each array reference. Probably it would be worse though. + '(do ((dst-index (the (or (eql -1) index) (+ dst-start nwords -1)) + (1- dst-index)) + (src-index (the (or (eql -1) index) (+ src-start nwords -1)) + (1- src-index))) + ((< dst-index dst-start)) + (declare (type (or (eql -1) index) dst-index src-index)) + ;; Assigning into SRC is right, because DST and SRC are the same array. + ;; We don't need "both" arrays to be in registers. + (%set-vector-raw-bits src dst-index + (%vector-raw-bits src (the index src-index))))) + (up () + '(do ((dst-index dst-start (the index (1+ dst-index))) + (src-index src-start (the index (1+ src-index)))) + ((>= dst-index dst-end)) + (%set-vector-raw-bits dst dst-index (%vector-raw-bits src src-index)))) + (use-memmove () + ;; %BYTE-BLT wants the end as an index, which it converts back to a count + ;; by subtracting the start. Regardless, the args are way too confusing, + ;; so let's go directly to memmove. Cribbed from (DEFTRANSFORM %BYTE-BLT) + `(with-pinned-objects (dst src) + (memmove (sap+ (vector-sap (the ,vtype dst)) + (the signed-word (* dst-start ,bytes-per-element))) + (sap+ (vector-sap (the ,vtype src)) + (the signed-word (* src-start ,bytes-per-element))) + (the word (* nelements ,bytes-per-element)))))) + ;; The arguments are array element indices. + `(defun ,(intern (format nil "UB~D-BASH-COPY" bits-per-element) + (find-package "SB-KERNEL")) + (src src-start dst dst-start nelements) + (declare (type index src-start dst-start nelements)) + (verify-src/dst-bits-per-elt src dst ,bits-per-element) + (locally + (declare (optimize (safety 0) + (sb-c::alien-funcall-saves-fp-and-pc 0))) + ,(if (= bytes-per-element sb-vm:n-word-bytes) + `(if ,always-call-out-p + ,(use-memmove) + (let ((nwords nelements)) + (if ,(backward-p) + ,(down) + (let ((dst-end (the index (+ dst-start nelements)))) + ,(up))))) + `(let ((dst-subword (mod dst-start ,elements-per-word)) + (src-subword (mod src-start ,elements-per-word)) + (dst (truly-the ,vtype dst)) + (src (truly-the ,vtype src))) + (cond ((or ,always-call-out-p + (/= dst-subword src-subword)) ; too complicated + ,(use-memmove)) + (,(backward-p) + ;; Using the primitive-type-specific data-vector-set, + ;; process at most (1- ELEMENTS-PER-WORD) elements + ;; until aligned to a word. + (let ((dst-end (+ dst-start nelements)) + (src-end (+ src-start nelements)) + (original-nelements nelements)) + ,@(let (initial) + (loop for i downfrom (- elements-per-word 1) + repeat (1- elements-per-word) + do (setq initial + ;; Test NELEMENTS first because it should be in a register + ;; from the preceding DECF. + `((when (and (/= nelements 0) + (logtest dst-end ,(1- elements-per-word))) + (data-vector-set dst (1- dst-end) + (data-vector-ref src (- src-end ,i))) + (decf (the index dst-end)) + (decf (the index nelements)) + ,@initial)))) + initial) + (decf src-end (the (mod 8) (- original-nelements nelements))) + ;; Now DST-END and SRC-END are element indices that start a word. + ;; Scan backwards by whole words. + (let ((nwords (truncate nelements ,elements-per-word))) + (when (plusp nwords) + ;; Convert to word indices + (let* ((dst-start (- (truncate dst-end ,elements-per-word) nwords)) + (src-start (- (truncate src-end ,elements-per-word) nwords))) + ,(down)) + (decf (the index dst-end) (* nwords ,elements-per-word)) + (decf (the index src-end) (* nwords ,elements-per-word)) + (decf nelements (* nwords ,elements-per-word)))) + ;; If there are elements remaining after the last full word copied, + ;; process element by element. + ,@(let (final) + (loop for i from (1- elements-per-word) downto 1 + do (setq final + `((unless (= nelements 0) + (data-vector-set + dst (- dst-end ,i) + (data-vector-ref src (- src-end ,i))) + ,@(unless (= i (1- elements-per-word)) + '((decf (the index nelements)))) + ,@final)))) + final))) + (t + ;; Same as above + (let ((original-nelements nelements)) + ,@(let (initial) + (loop for i downfrom (- elements-per-word 2) + repeat (1- elements-per-word) + do (setq initial + `((when (and (/= nelements 0) + (logtest dst-start ,(1- elements-per-word))) + (data-vector-set + dst dst-start + (data-vector-ref src (+ src-start ,i))) + (incf (the index dst-start)) + (decf (the index nelements)) + ,@initial)))) + initial) + (incf (the index src-start) (- original-nelements nelements))) + (let ((nwords (truncate nelements ,elements-per-word))) + (when (plusp nwords) + (let* ((src-start (truncate src-start ,elements-per-word)) + (dst-start (truncate dst-start ,elements-per-word)) + (dst-end (the index (+ dst-start nwords)))) + ,(up)) + (incf dst-start (* nwords ,elements-per-word)) + (incf src-start (* nwords ,elements-per-word)) + (decf nelements (* nwords ,elements-per-word)))) + ;; Same as above + ,@(let (final) + (loop for i from (- elements-per-word 2) downto 0 + do (setq final + `((unless (= nelements 0) + (data-vector-set + dst (+ dst-start ,i) + (data-vector-ref src (+ src-start ,i))) + ,@(unless (= i (- elements-per-word 2)) + '((decf (the index nelements)))) + ,@final)))) + final))))) + (values))))) + +(define-byte-blt-copier 1) +(define-byte-blt-copier 2) +(define-byte-blt-copier 4) +#+64-bit (define-byte-blt-copier 8) ;;; We cheat a little bit by using TRULY-THE in the copying function to ;;; force the compiler to generate good code in the (= BITSIZE @@ -153,26 +227,16 @@ (let* ((bytes-per-word (/ n-word-bits bitsize)) (byte-offset `(integer 0 (,bytes-per-word))) (word-offset `(integer 0 ,(ceiling array-dimension-limit bytes-per-word))) - (fix-sap-and-offset-name (intern (format nil "FIX-SAP-AND-OFFSET-UB~D" bitsize))) (constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB-KERNEL"))) (array-fill-name (intern (format nil "UB~D-BASH-FILL" bitsize) (find-package "SB-KERNEL"))) - (system-area-fill-name (intern (format nil "SYSTEM-AREA-UB~D-FILL" bitsize) (find-package "SB-KERNEL"))) (unary-bash-name (intern (format nil "UNARY-UB~D-BASH" bitsize) (find-package "SB-KERNEL"))) - (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB-KERNEL"))) - (system-area-copy-name (intern (format nil "SYSTEM-AREA-UB~D-COPY" bitsize) (find-package "SB-KERNEL"))) - (array-copy-to-system-area-name - (intern (format nil "COPY-UB~D-TO-SYSTEM-AREA" bitsize) (find-package "SB-KERNEL"))) - (system-area-copy-to-array-name - (intern (format nil "COPY-UB~D-FROM-SYSTEM-AREA" bitsize) - (find-package "SB-KERNEL")))) + (array-copy-name (intern (format nil "UB~D-BASH-COPY" bitsize) (find-package "SB-KERNEL")))) `(progn - (declaim (inline ,constant-bash-name ,unary-bash-name)) + (declaim (inline ,constant-bash-name)) ;; Fill DST with VALUE starting at DST-OFFSET and continuing ;; for LENGTH bytes (however bytes are defined). - (defun ,constant-bash-name (dst dst-offset length value - dst-ref-fn dst-set-fn) + (defun ,constant-bash-name (dst dst-offset length value) (declare (type word value) (type index dst-offset length)) - (declare (ignorable dst-ref-fn)) (multiple-value-bind (dst-word-offset dst-byte-offset) (floor dst-offset ,bytes-per-word) (declare (type ,word-offset dst-word-offset) @@ -184,40 +248,40 @@ (if (zerop n-words) ,(unless (= bytes-per-word 1) `(unless (zerop length) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (if (>= length ,bytes-per-word) value (let ((mask (shift-towards-end (start-mask (* length ,bitsize)) (* dst-byte-offset ,bitsize)))) (word-logical-or (word-logical-and value mask) - (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) + (word-logical-andc2 (%vector-raw-bits dst dst-word-offset) mask))))))) (let ((interior (floor (- length final-bytes) ,bytes-per-word))) ,@(unless (= bytes-per-word 1) `((unless (zerop dst-byte-offset) (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize)))) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) - (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) + (word-logical-andc2 (%vector-raw-bits dst dst-word-offset) mask)))) (incf dst-word-offset)))) (let ((end (+ dst-word-offset interior))) (declare (type ,word-offset end)) (do () ((>= dst-word-offset end)) - (funcall dst-set-fn dst dst-word-offset value) + (%set-vector-raw-bits dst dst-word-offset value) (incf dst-word-offset))) #+nil (dotimes (i interior) - (funcall dst-set-fn dst dst-word-offset value) + (%set-vector-raw-bits dst dst-word-offset value) (incf dst-word-offset)) ,@(unless (= bytes-per-word 1) `((unless (zerop final-bytes) (let ((mask (start-mask (* final-bytes ,bitsize)))) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) - (word-logical-andc2 (funcall dst-ref-fn dst dst-word-offset) + (word-logical-andc2 (%vector-raw-bits dst dst-word-offset) mask))))))))))) (values)) @@ -230,22 +294,15 @@ (defun ,array-fill-name (value dst dst-offset length) (declare (type word value) (type index dst-offset length)) (declare (optimize (speed 3) (safety 1))) - (,constant-bash-name dst dst-offset length value - #'%vector-raw-bits #'%set-vector-raw-bits) + (,constant-bash-name dst dst-offset length value) dst) - (defun ,system-area-fill-name (value dst dst-offset length) - (declare (type word value) (type index dst-offset length)) - (declare (optimize (speed 3) (safety 1))) - (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset) - (,constant-bash-name dst dst-offset length value - #'word-sap-ref #'%set-word-sap-ref))) - - ;; unary byte bashing (copying) - (defun ,unary-bash-name (src src-offset dst dst-offset length - dst-ref-fn dst-set-fn src-ref-fn) - (declare (type index src-offset dst-offset length) - (type function dst-ref-fn dst-set-fn src-ref-fn) - (ignorable dst-ref-fn)) + + ;; Copying. Never use this for 8, 16, 32, 64 + ,@(when (member bitsize '(1 2 4)) + `((declaim (inline ,unary-bash-name)) + (defun ,unary-bash-name (src src-offset dst dst-offset length) + (declare (type index src-offset dst-offset length)) + (verify-src/dst-bits-per-elt src dst ,bitsize) (multiple-value-bind (dst-word-offset dst-byte-offset) (floor dst-offset ,bytes-per-word) (declare (type ,word-offset dst-word-offset) @@ -268,16 +325,16 @@ ;; writing multiple words. If SRC-BYTE-OFFSET is also zero, ;; the we just transfer the single word. Otherwise we have ;; to extract bytes from two source words. - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (cond ((zerop src-byte-offset) - (funcall src-ref-fn src src-word-offset)) + (%vector-raw-bits src src-word-offset)) ,@(unless (= bytes-per-word 1) `((t (word-logical-or (shift-towards-start - (funcall src-ref-fn src src-word-offset) + (%vector-raw-bits src src-word-offset) (* src-byte-offset ,bitsize)) (shift-towards-end - (funcall src-ref-fn src (1+ src-word-offset)) + (%vector-raw-bits src (1+ src-word-offset)) (* (- src-byte-offset) ,bitsize))))))))) ,@(unless (= bytes-per-word 1) `((t @@ -285,7 +342,7 @@ ;; We still don't know whether we need one or two source words. (let ((mask (shift-towards-end (start-mask (* length ,bitsize)) (* dst-byte-offset ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset)) + (orig (%vector-raw-bits dst dst-word-offset)) (value (if (> src-byte-offset dst-byte-offset) ;; The source starts further ;; into the word than does the @@ -300,12 +357,12 @@ (if (> (+ src-byte-offset length) ,bytes-per-word) (word-logical-or (shift-towards-start - (funcall src-ref-fn src src-word-offset) + (%vector-raw-bits src src-word-offset) (* src-byte-shift ,bitsize)) (shift-towards-end - (funcall src-ref-fn src (1+ src-word-offset)) + (%vector-raw-bits src (1+ src-word-offset)) (* (- src-byte-shift) ,bitsize))) - (shift-towards-start (funcall src-ref-fn src src-word-offset) + (shift-towards-start (%vector-raw-bits src src-word-offset) (* src-byte-shift ,bitsize)))) ;; The destination starts further ;; into the word than does the @@ -315,10 +372,10 @@ ;; would too, and we wouldn't be ;; in this branch). (shift-towards-end - (funcall src-ref-fn src src-word-offset) + (%vector-raw-bits src src-word-offset) (* (- dst-byte-offset src-byte-offset) ,bitsize))))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask))))))))) ((= src-byte-offset dst-byte-offset) @@ -340,10 +397,10 @@ ;; We are only writing part of the first word, so mask ;; off the bytes we want to preserve. (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) + (orig (%vector-raw-bits dst dst-word-offset)) + (value (%vector-raw-bits src src-word-offset))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask)))) (incf src-word-offset) @@ -356,8 +413,8 @@ (declare (type ,word-offset end)) (do () ((>= dst-word-offset end)) - (funcall dst-set-fn dst dst-word-offset - (funcall src-ref-fn src src-word-offset)) + (%set-vector-raw-bits dst dst-word-offset + (%vector-raw-bits src src-word-offset)) ,(if (= bytes-per-word 1) `(setf src-word-offset (truly-the ,word-offset (+ src-word-offset 1))) `(incf src-word-offset)) @@ -366,10 +423,10 @@ `((unless (zerop final-bytes) ;; We are only writing part of the last word. (let ((mask (start-mask (* final-bytes ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) + (orig (%vector-raw-bits dst dst-word-offset)) + (value (%vector-raw-bits src src-word-offset))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask)))))))) (t @@ -385,10 +442,10 @@ ,@(unless (= bytes-per-word 1) `((unless (zerop final-bytes) (let ((mask (start-mask (* final-bytes ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) + (orig (%vector-raw-bits dst dst-word-offset)) + (value (%vector-raw-bits src src-word-offset))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask))))))) (let ((end (- dst-word-offset interior))) @@ -396,18 +453,18 @@ ((<= dst-word-offset end)) (decf src-word-offset) (decf dst-word-offset) - (funcall dst-set-fn dst dst-word-offset - (funcall src-ref-fn src src-word-offset)))) + (%set-vector-raw-bits dst dst-word-offset + (%vector-raw-bits src src-word-offset)))) ,@(unless (= bytes-per-word 1) `((unless (zerop dst-byte-offset) ;; We are only writing part of the last word. (decf src-word-offset) (decf dst-word-offset) (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset)) - (value (funcall src-ref-fn src src-word-offset))) + (orig (%vector-raw-bits dst dst-word-offset)) + (value (%vector-raw-bits src src-word-offset))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask)))))))))))) (t @@ -425,11 +482,11 @@ ((<= dst-offset src-offset) ;; We need to loop from left to right. (let ((prev 0) - (next (funcall src-ref-fn src src-word-offset))) + (next (%vector-raw-bits src src-word-offset))) (declare (type word prev next)) (flet ((get-next-src () (setf prev next) - (setf next (funcall src-ref-fn src + (setf next (%vector-raw-bits src (incf src-word-offset))))) (declare (inline get-next-src)) ,@(unless (= bytes-per-word 1) @@ -437,11 +494,11 @@ (when (> src-byte-offset dst-byte-offset) (get-next-src)) (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset)) + (orig (%vector-raw-bits dst dst-word-offset)) (value (word-logical-or (shift-towards-start prev (* src-shift ,bitsize)) (shift-towards-end next (* (- src-shift) ,bitsize))))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask)))) (incf dst-word-offset)))) @@ -454,7 +511,7 @@ (shift-towards-end next (* (- src-shift) ,bitsize)) (shift-towards-start prev (* src-shift ,bitsize))))) (declare (type word value)) - (funcall dst-set-fn dst dst-word-offset value) + (%set-vector-raw-bits dst dst-word-offset value) (incf dst-word-offset)))) ,@(unless (= bytes-per-word 1) `((unless (zerop final-bytes) @@ -467,9 +524,9 @@ (shift-towards-start prev (* src-shift ,bitsize)))) (shift-towards-start next (* src-shift ,bitsize)))) (mask (start-mask (* final-bytes ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset))) + (orig (%vector-raw-bits dst dst-word-offset))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask)))))))))) (t @@ -477,11 +534,11 @@ (incf dst-word-offset words) (incf src-word-offset (1- (ceiling (+ src-byte-offset length) ,bytes-per-word))) (let ((next 0) - (prev (funcall src-ref-fn src src-word-offset))) + (prev (%vector-raw-bits src src-word-offset))) (declare (type word prev next)) (flet ((get-next-src () (setf next prev) - (setf prev (funcall src-ref-fn src (decf src-word-offset))))) + (setf prev (%vector-raw-bits src (decf src-word-offset))))) (declare (inline get-next-src)) ,@(unless (= bytes-per-word 1) `((unless (zerop final-bytes) @@ -491,9 +548,9 @@ (shift-towards-end next (* (- src-shift) ,bitsize)) (shift-towards-start prev (* src-shift ,bitsize)))) (mask (start-mask (* final-bytes ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset))) + (orig (%vector-raw-bits dst dst-word-offset))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask))))))) (decf dst-word-offset) @@ -505,7 +562,7 @@ (shift-towards-end next (* (- src-shift) ,bitsize)) (shift-towards-start prev (* src-shift ,bitsize))))) (declare (type word value)) - (funcall dst-set-fn dst dst-word-offset value) + (%set-vector-raw-bits dst dst-word-offset value) (decf dst-word-offset)))) ,@(unless (= bytes-per-word 1) `((unless (zerop dst-byte-offset) @@ -513,12 +570,12 @@ (get-next-src) (setf next prev prev 0)) (let ((mask (end-mask (* (- dst-byte-offset) ,bitsize))) - (orig (funcall dst-ref-fn dst dst-word-offset)) + (orig (%vector-raw-bits dst dst-word-offset)) (value (word-logical-or (shift-towards-start prev (* src-shift ,bitsize)) (shift-towards-end next (* (- src-shift) ,bitsize))))) (declare (type word mask orig value)) - (funcall dst-set-fn dst dst-word-offset + (%set-vector-raw-bits dst dst-word-offset (word-logical-or (word-logical-and value mask) (word-logical-andc2 orig mask))))))))))))))))) (values)) @@ -527,52 +584,15 @@ (defun ,array-copy-name (src src-offset dst dst-offset length) (declare (type index src-offset dst-offset length)) (locally (declare (optimize (speed 3) (safety 1))) - (,unary-bash-name src src-offset dst dst-offset length - #'%vector-raw-bits - #'%set-vector-raw-bits - #'%vector-raw-bits))) - - (defun ,system-area-copy-name (src src-offset dst dst-offset length) - (declare (type index src-offset dst-offset length)) - (locally (declare (optimize (speed 3) (safety 1))) - (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset) - (declare (type system-area-pointer src)) - (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset) - (declare (type system-area-pointer dst)) - (,unary-bash-name src src-offset dst dst-offset length - #'word-sap-ref #'%set-word-sap-ref - #'word-sap-ref))))) - - (defun ,array-copy-to-system-area-name (src src-offset dst dst-offset length) - (declare (type index src-offset dst-offset length)) - (locally (declare (optimize (speed 3) (safety 1))) - (multiple-value-bind (dst dst-offset) (,fix-sap-and-offset-name dst dst-offset) - (,unary-bash-name src src-offset dst dst-offset length - #'word-sap-ref #'%set-word-sap-ref - #'%vector-raw-bits)))) - - (defun ,system-area-copy-to-array-name (src src-offset dst dst-offset length) - (declare (type index src-offset dst-offset length)) - (locally (declare (optimize (speed 3) (safety 1))) - (multiple-value-bind (src src-offset) (,fix-sap-and-offset-name src src-offset) - (,unary-bash-name src src-offset dst dst-offset length - #'%vector-raw-bits - #'%set-vector-raw-bits - #'word-sap-ref))))))) -) ; EVAL-WHEN + (,unary-bash-name src src-offset dst dst-offset length)))))))) -(eval-when (:compile-toplevel) - (sb-xc:proclaim '(muffle-conditions compiler-note))) ;;; We would normally do this with a MACROLET, but then we run into ;;; problems with the lexical environment being too hairy for the ;;; cross-compiler and it cannot inline the basic basher functions. #.(loop for i = 1 then (* i 2) - collect `(!define-sap-fixer ,i) into fixers collect `(!define-byte-bashers ,i) into bashers until (= i n-word-bits) - ;; FIXERS must come first so their inline expansions are available - ;; for the bashers. - finally (return `(progn ,@fixers ,@bashers))) + finally (return `(progn ,@bashers))) (defmacro !define-constant-byte-bashers (bitsize type value-transformer &optional (name type)) (let ((constant-bash-name (intern (format nil "CONSTANT-UB~D-BASH" bitsize) (find-package "SB-KERNEL"))) @@ -586,8 +606,7 @@ (defun ,array-fill-name (value dst dst-offset length) (declare (type ,type value) (type index dst-offset length)) (declare (optimize (speed 3) (safety 1))) - (,constant-bash-name dst dst-offset length (,value-transformer value) - #'%vector-raw-bits #'%set-vector-raw-bits) + (,constant-bash-name dst dst-offset length (,value-transformer value)) dst)))) (macrolet ((def () diff -Nru sbcl-2.1.1/src/code/cas.lisp sbcl-2.1.11/src/code/cas.lisp --- sbcl-2.1.1/src/code/cas.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cas.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1,422 +1,10 @@ (in-package "SB-IMPL") -;;;; COMPARE-AND-SWAP -;;;; -;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now. -;;;; -;;;; Internally our interface has CAS, GET-CAS-EXPANSION, DEFINE-CAS-EXPANDER, -;;;; DEFCAS, and #'(CAS ...) functions -- making things mostly isomorphic with -;;;; SETF. - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun expand-structure-slot-cas (info name place) - (let* ((dd (car info)) - (structure (dd-name dd)) - (slotd (cdr info)) - (index (dsd-index slotd)) - (type (dsd-type slotd)) - (casser - (case (dsd-raw-type slotd) - ((t) '%instance-cas) - #+(or arm64 ppc ppc64 riscv x86 x86-64) - ((word) '%raw-instance-cas/word) - #+riscv - ((signed-word) '%raw-instance-cas/signed-word)))) - (unless casser - (error "Cannot use COMPARE-AND-SWAP with structure accessor ~ - for a typed slot: ~S" - place)) - (when (dsd-read-only slotd) - (error "Cannot use COMPARE-AND-SWAP with structure accessor ~ - for a read-only slot: ~S" - place)) - (destructuring-bind (op arg) place - (aver (eq op name)) - (with-unique-names (instance old new) - (values (list instance) - (list `(the ,structure ,arg)) - old - new - `(truly-the (values ,type &optional) - (,casser ,instance ,index - (the ,type ,old) - (the ,type ,new))) - `(,op ,instance)))))) - -(defun get-cas-expansion (place &optional environment) - "Analogous to GET-SETF-EXPANSION. Returns the following six values: - - * list of temporary variables - - * list of value-forms whose results those variable must be bound - - * temporary variable for the old value of PLACE - - * temporary variable for the new value of PLACE - - * form using the aforementioned temporaries which performs the - compare-and-swap operation on PLACE - - * form using the aforementioned temporaries with which to perform a volatile - read of PLACE - -Example: - - (get-cas-expansion '(car x)) - ; => (#:CONS871), (X), #:OLD872, #:NEW873, - ; (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873). - ; (CAR #:CONS871) - - (defmacro my-atomic-incf (place &optional (delta 1) &environment env) - (multiple-value-bind (vars vals old new cas-form read-form) - (get-cas-expansion place env) - (let ((delta-value (gensym \"DELTA\"))) - `(let* (,@(mapcar 'list vars vals) - (,old ,read-form) - (,delta-value ,delta) - (,new (+ ,old ,delta-value))) - (loop until (eq ,old (setf ,old ,cas-form)) - do (setf ,new (+ ,old ,delta-value))) - ,new)))) - -EXPERIMENTAL: Interface subject to change." - ;; FIXME: this seems wrong on two points: - ;; 1. if TRULY-THE had a CAS expander (which it doesn't) we'd want - ;; to use %MACROEXPAND[-1] so as not to lose the "truly-the"-ness - ;; 2. if both a CAS expander and a macro exist, the CAS expander - ;; should be preferred before macroexpanding (just like SETF does) - (let ((expanded (macroexpand place environment))) - (flet ((invalid-place () - (error "Invalid place to CAS: ~S -> ~S" place expanded))) - (unless (consp expanded) - (cond ((and (symbolp expanded) - (member (info :variable :kind expanded) - '(:global :special))) - (setq expanded `(symbol-value ',expanded))) - (t - (invalid-place)))) - (let ((name (car expanded))) - (unless (symbolp name) - (invalid-place)) - (acond - ((info :cas :expander name) - ;; CAS expander. - (funcall it expanded environment)) - - ;; Structure accessor - ((structure-instance-accessor-p name) - (expand-structure-slot-cas it name expanded)) - - ;; CAS function - (t - (with-unique-names (old new) - (let ((vars nil) - (vals nil) - (args nil)) - (dolist (x (reverse (cdr expanded))) - (cond ((constantp x environment) - (push x args)) - (t - (let ((tmp (gensymify x))) - (push tmp args) - (push tmp vars) - (push x vals))))) - (values vars vals old new - `(funcall #'(cas ,name) ,old ,new ,@args) - `(,name ,@args)))))))))) -) - -;;; This is what it all comes down to. -(defmacro cas (place old new &environment env) - "Synonym for COMPARE-AND-SWAP. - -Additionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to -define CAS-functions analogously to SETF-functions: - - (defvar *foo* nil) - - (defun (cas foo) (old new) - (cas (symbol-value '*foo*) old new)) - -First argument of a CAS function is the expected old value, and the second -argument of is the new value. Note that the system provides no automatic -atomicity for CAS functions, nor can it verify that they are atomic: it is up -to the implementor of a CAS function to ensure its atomicity. - -EXPERIMENTAL: Interface subject to change." - (multiple-value-bind (temps place-args old-temp new-temp cas-form) - (get-cas-expansion place env) - `(let* (,@(mapcar #'list temps place-args) - (,old-temp ,old) - (,new-temp ,new)) - ,cas-form))) - -(defmacro define-cas-expander (accessor lambda-list &body body) - "Analogous to DEFINE-SETF-EXPANDER. Defines a CAS-expansion for ACCESSOR. -BODY must return six values as specified in GET-CAS-EXPANSION. - -Note that the system provides no automatic atomicity for CAS expansion, nor -can it verify that they are atomic: it is up to the implementor of a CAS -expansion to ensure its atomicity. - -EXPERIMENTAL: Interface subject to change." - `(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (info :cas :expander ',accessor) - ,(make-macro-lambda `(cas-expand ,accessor) lambda-list body - 'define-cas-expander accessor)))) - -;; FIXME: this interface is bogus - short-form DEFSETF/CAS does not -;; want a lambda-list. You just blindly substitute -;; (CAS (PLACE arg1 ... argN) old new) -> (F arg1 ... argN old new). -;; What role can this lambda-list have when there is no user-provided -;; code to read the variables? -;; And as mentioned no sbcl-devel, &REST is beyond bogus, it's broken. -;; -(defmacro defcas (accessor lambda-list function &optional docstring) - "Analogous to short-form DEFSETF. Defines FUNCTION as responsible -for compare-and-swap on places accessed using ACCESSOR. LAMBDA-LIST -must correspond to the lambda-list of the accessor. - -Note that the system provides no automatic atomicity for CAS expansions -resulting from DEFCAS, nor can it verify that they are atomic: it is up to the -user of DEFCAS to ensure that the function specified is atomic. - -EXPERIMENTAL: Interface subject to change." - (multiple-value-bind (llks reqs opts rest) - (parse-lambda-list lambda-list - :accept (lambda-list-keyword-mask '(&optional &rest)) - :context "a DEFCAS lambda-list") - (declare (ignore llks)) - `(define-cas-expander ,accessor ,lambda-list - ,@(when docstring (list docstring)) - ;; FIXME: if a &REST arg is present, this is really weird. - (let ((temps (mapcar #'gensymify ',(append reqs opts rest))) - (args (list ,@(append reqs opts rest))) - (old (gensym "OLD")) - (new (gensym "NEW"))) - (values temps - args - old - new - `(,',function ,@temps ,old ,new) - `(,',accessor ,@temps)))))) - -(defmacro compare-and-swap (place old new) - "Atomically stores NEW in PLACE if OLD matches the current value of PLACE. -Two values are considered to match if they are EQ. Returns the previous value -of PLACE: if the returned value is EQ to OLD, the swap was carried out. - -PLACE must be an CAS-able place. Built-in CAS-able places are accessor forms -whose CAR is one of the following: - - CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE - SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS, - -or the name of a DEFSTRUCT created accessor for a slot whose storage type -is not raw. (Refer to the the \"Efficiency\" chapter of the manual -for the list of raw slot types. Future extensions to this macro may allow -it to work on some raw slot types.) - -In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless -OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is -returned and NEW is assigned to the slot. Additionally, the results are -unspecified if there is an applicable method on either -SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or -SB-MOP:SLOT-BOUNDP-USING-CLASS. - -Additionally, the PLACE can be a anything for which a CAS-expansion has been -specified using DEFCAS, DEFINE-CAS-EXPANDER, or for which a CAS-function has -been defined. (See SB-EXT:CAS for more information.) -" - `(cas ,place ,old ,new)) - -(defcas car (cons) %compare-and-swap-car) -(defcas cdr (cons) %compare-and-swap-cdr) -(defcas first (cons) %compare-and-swap-car) -(defcas rest (cons) %compare-and-swap-cdr) -(defcas symbol-plist (symbol) %compare-and-swap-symbol-plist) - -(define-cas-expander symbol-value (name &environment env) - (multiple-value-bind (tmp val cname) - (if (constantp name env) - (values nil nil (constant-form-value name env)) - (values (gensymify name) name nil)) - (let ((symbol (or tmp `',cname))) - (with-unique-names (old new) - (values (when tmp (list tmp)) - (when val (list val)) - old - new - (if (and cname (member (info :variable :kind cname) '(:special :global))) - ;; We can generate the type-check reasonably. - `(%compare-and-swap-symbol-value - ',cname ,old (the ,(info :variable :type cname) ,new)) - `(progn - (about-to-modify-symbol-value ,symbol 'compare-and-swap ,new) - (%compare-and-swap-symbol-value ,symbol ,old ,new))) - `(symbol-value ,symbol)))))) - -(define-cas-expander svref (vector index) - (with-unique-names (v i old new) - (values (list v i) - (list vector index) - old - new - `(locally (declare (simple-vector ,v)) - (%compare-and-swap-svref ,v (check-bound ,v (length ,v) ,i) ,old ,new)) - `(svref ,v ,i)))) - -;;;; ATOMIC-INCF and ATOMIC-DECF - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun expand-atomic-frob - (name specified-place diff env - &aux (place (macroexpand specified-place env))) - (declare (type (member atomic-incf atomic-decf) name)) - (flet ((invalid-place () - (error "Invalid first argument to ~S: ~S" name specified-place)) - (compute-newval (old) ; used only if no atomic inc vop - `(logand (,(case name (atomic-incf '+) (atomic-decf '-)) ,old - (the sb-vm:signed-word ,diff)) sb-ext:most-positive-word)) - (compute-delta () ; used only with atomic inc vop - `(logand ,(case name - (atomic-incf `(the sb-vm:signed-word ,diff)) - (atomic-decf `(- (the sb-vm:signed-word ,diff)))) - sb-ext:most-positive-word))) - (declare (ignorable #'compute-newval #'compute-delta)) - (when (and (symbolp place) - (eq (info :variable :kind place) :global) - (type= (info :variable :type place) (specifier-type 'fixnum))) - ;; Global can't be lexically rebound. - (return-from expand-atomic-frob - `(truly-the fixnum (,(case name - (atomic-incf '%atomic-inc-symbol-global-value) - (atomic-decf '%atomic-dec-symbol-global-value)) - ',place (the fixnum ,diff))))) - (unless (consp place) (invalid-place)) - (destructuring-bind (op . args) place - ;; FIXME: The lexical environment should not be disregarded. - ;; CL builtins can't be lexically rebound, but structure accessors can. - (case op - (aref - (unless (singleton-p (cdr args)) - (invalid-place)) - (with-unique-names (array) - `(let ((,array (the (simple-array word (*)) ,(car args)))) - #+compare-and-swap-vops - (%array-atomic-incf/word - ,array - (check-bound ,array (array-dimension ,array 0) ,(cadr args)) - ,(compute-delta)) - #-compare-and-swap-vops - ,(with-unique-names (index old-value) - `(without-interrupts - (let* ((,index ,(cadr args)) - (,old-value (aref ,array ,index))) - (setf (aref ,array ,index) ,(compute-newval old-value)) - ,old-value)))))) - ((car cdr first rest) - (when (cdr args) - (invalid-place)) - `(truly-the - fixnum - (,(case op - ((first car) (case name - (atomic-incf '%atomic-inc-car) - (atomic-decf '%atomic-dec-car))) - ((rest cdr) (case name - (atomic-incf '%atomic-inc-cdr) - (atomic-decf '%atomic-dec-cdr)))) - ,(car args) (the fixnum ,diff)))) - (t - (when (or (cdr args) - ;; Because accessor info is identical for the writer and reader - ;; functions, without a SYMBOLP check this would erroneously allow - ;; (ATOMIC-INCF ((SETF STRUCT-SLOT) x)) - (not (symbolp op)) - (not (structure-instance-accessor-p op))) - (invalid-place)) - (let* ((accessor-info (structure-instance-accessor-p op)) - (slotd (cdr accessor-info)) - (type (dsd-type slotd))) - (unless (and (eq 'sb-vm:word (dsd-raw-type slotd)) - (type= (specifier-type type) (specifier-type 'sb-vm:word))) - (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" - name sb-vm:n-word-bits type place)) - (when (dsd-read-only slotd) - (error "Cannot use ~S with structure accessor for a read-only slot: ~S" - name place)) - #+compare-and-swap-vops - `(truly-the sb-vm:word - (%raw-instance-atomic-incf/word - (the ,(dd-name (car accessor-info)) ,@args) - ,(dsd-index slotd) - ,(compute-delta))) - #-compare-and-swap-vops - (with-unique-names (structure old-value) - `(without-interrupts - (let* ((,structure ,@args) - (,old-value (,op ,structure))) - (setf (,op ,structure) ,(compute-newval old-value)) - ,old-value)))))))))) - -(defmacro atomic-incf (&environment env place &optional (diff 1)) - #.(format nil - "Atomically increments PLACE by DIFF, and returns the value of PLACE before -the increment. - -PLACE must access one of the following: - - a DEFSTRUCT slot with declared type (UNSIGNED-BYTE ~D~:*) - or AREF of a (SIMPLE-ARRAY (UNSIGNED-BYTE ~D~:*) (*)) - The type SB-EXT:WORD can be used for these purposes. - - CAR or CDR (respectively FIRST or REST) of a CONS. - - a variable defined using DEFGLOBAL with a proclaimed type of FIXNUM. -Macroexpansion is performed on PLACE before expanding ATOMIC-INCF. - -Incrementing is done using modular arithmetic, -which is well-defined over two different domains: - - For structures and arrays, the operation accepts and produces - an (UNSIGNED-BYTE ~D~:*), and DIFF must be of type (SIGNED-BYTE ~D). - ATOMIC-INCF of #x~x by one results in #x0 being stored in PLACE. - - For other places, the domain is FIXNUM, and DIFF must be a FIXNUM. - ATOMIC-INCF of #x~x by one results in #x~x - being stored in PLACE. - -DIFF defaults to 1. - -EXPERIMENTAL: Interface subject to change." - sb-vm:n-word-bits most-positive-word - most-positive-fixnum most-negative-fixnum) - (expand-atomic-frob 'atomic-incf place diff env)) - -(defmacro atomic-decf (&environment env place &optional (diff 1)) - #.(format nil - "Atomically decrements PLACE by DIFF, and returns the value of PLACE before -the decrement. - -PLACE must access one of the following: - - a DEFSTRUCT slot with declared type (UNSIGNED-BYTE ~D~:*) - or AREF of a (SIMPLE-ARRAY (UNSIGNED-BYTE ~D~:*) (*)) - The type SB-EXT:WORD can be used for these purposes. - - CAR or CDR (respectively FIRST or REST) of a CONS. - - a variable defined using DEFGLOBAL with a proclaimed type of FIXNUM. -Macroexpansion is performed on PLACE before expanding ATOMIC-DECF. - -Decrementing is done using modular arithmetic, -which is well-defined over two different domains: - - For structures and arrays, the operation accepts and produces - an (UNSIGNED-BYTE ~D~:*), and DIFF must be of type (SIGNED-BYTE ~D). - ATOMIC-DECF of #x0 by one results in #x~x being stored in PLACE. - - For other places, the domain is FIXNUM, and DIFF must be a FIXNUM. - ATOMIC-DECF of #x~x by one results in #x~x - being stored in PLACE. - -DIFF defaults to 1. - -EXPERIMENTAL: Interface subject to change." - sb-vm:n-word-bits most-positive-word - most-negative-fixnum most-positive-fixnum) - (expand-atomic-frob 'atomic-decf place diff env)) +(declaim (inline (cas car) (cas cdr) (cas first) (cas rest))) +(defun (cas car) (old new cons) (%compare-and-swap-car cons old new)) +(defun (cas cdr) (old new cons) (%compare-and-swap-cdr cons old new)) +(defun (cas first) (old new cons) (%compare-and-swap-car cons old new)) +(defun (cas rest) (old new cons) (%compare-and-swap-cdr cons old new)) ;;; Out-of-line definitions for various primitive cas functions. (macrolet ((def (name lambda-list ref &optional set) @@ -439,6 +27,9 @@ current))))) (def %compare-and-swap-car (cons) car) (def %compare-and-swap-cdr (cons) cdr) + ;; %instance-set is OK here even though it doesn't return a value + ;; because it is used for effect. And if compare-and-swap vops exist, + ;; then the setter isn't used at all. (def %instance-cas (instance index) %instance-ref %instance-set) #+(or x86-64 x86 riscv) (def %raw-instance-cas/word (instance index) @@ -448,7 +39,6 @@ (def %raw-instance-cas/signed-word (instance index) %raw-instance-ref/signed-word %raw-instance-set/signed-word) - (def %compare-and-swap-symbol-info (symbol) symbol-info) (def %compare-and-swap-symbol-value (symbol) symbol-value) (def %compare-and-swap-svref (vector index) svref)) @@ -484,71 +74,3 @@ (def-frob %atomic-dec-car - cons car) (def-frob %atomic-inc-cdr + cons cdr) (def-frob %atomic-dec-cdr - cons cdr))) - -(defmacro atomic-update (place update-fn &rest arguments &environment env) - "Updates PLACE atomically to the value returned by calling function -designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE. - -PLACE may be read and UPDATE-FN evaluated and called multiple times before the -update succeeds: atomicity in this context means that the value of PLACE did -not change between the time it was read, and the time it was replaced with the -computed value. - -PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP. - -Examples: - - ;;; Conses T to the head of FOO-LIST. - (defstruct foo list) - (defvar *foo* (make-foo)) - (atomic-update (foo-list *foo*) #'cons t) - - (let ((x (cons :count 0))) - (mapc #'sb-thread:join-thread - (loop repeat 1000 - collect (sb-thread:make-thread - (lambda () - (loop repeat 1000 - do (atomic-update (cdr x) #'1+) - (sleep 0.00001)))))) - ;; Guaranteed to be (:COUNT . 1000000) -- if you replace - ;; atomic update with (INCF (CDR X)) above, the result becomes - ;; unpredictable. - x) -" - (multiple-value-bind (vars vals old new cas-form read-form) - (get-cas-expansion place env) - `(let* (,@(mapcar 'list vars vals) - (,old ,read-form)) - (loop for ,new = (funcall ,update-fn ,@arguments ,old) - until (eq ,old (setf ,old ,cas-form)) - finally (return ,new))))) - -(defmacro atomic-push (obj place &environment env) - "Like PUSH, but atomic. PLACE may be read multiple times before -the operation completes -- the write does not occur until such time -that no other thread modified PLACE between the read and the write. - -Works on all CASable places." - (multiple-value-bind (vars vals old new cas-form read-form) - (get-cas-expansion place env) - `(let* (,@(mapcar 'list vars vals) - (,old ,read-form) - (,new (cons ,obj ,old))) - (loop until (eq ,old (setf ,old ,cas-form)) - do (setf (cdr ,new) ,old) - finally (return ,new))))) - -(defmacro atomic-pop (place &environment env) - "Like POP, but atomic. PLACE may be read multiple times before -the operation completes -- the write does not occur until such time -that no other thread modified PLACE between the read and the write. - -Works on all CASable places." - (multiple-value-bind (vars vals old new cas-form read-form) - (get-cas-expansion place env) - `(let* (,@(mapcar 'list vars vals) - (,old ,read-form)) - (loop (let ((,new (cdr ,old))) - (when (eq ,old (setf ,old ,cas-form)) - (return (car (truly-the list ,old))))))))) diff -Nru sbcl-2.1.1/src/code/class-init.lisp sbcl-2.1.11/src/code/class-init.lisp --- sbcl-2.1.1/src/code/class-init.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/class-init.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -;;;; When this file's top level forms are run, it precomputes the -;;;; translations for built in classes. This stuff is split off from -;;;; the other type stuff to get around problems with everything -;;;; needing to be loaded before everything else. This file is the -;;;; first to exercise the type machinery. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-KERNEL") - -;;; built-in classes -(/show0 "beginning class-init.lisp") -(dolist (x +!built-in-classes+) - (destructuring-bind (name &key (translation nil trans-p) &allow-other-keys) - x - (/show "doing class with" name) - (when trans-p - (let ((classoid (classoid-cell-classoid (find-classoid-cell name :create t))) - (type (specifier-type translation))) - ;; The classoid T gets its translation dumped in genesis. - ;; May as well double-check that it's right. - (when (typep (built-in-classoid-translation classoid) 'ctype) - (aver (eq (built-in-classoid-translation classoid) type))) - (setf (built-in-classoid-translation classoid) type) - (setf (info :type :builtin name) type))))) - -(/show0 "done with class-init.lisp") diff -Nru sbcl-2.1.1/src/code/class.lisp sbcl-2.1.11/src/code/class.lisp --- sbcl-2.1.1/src/code/class.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/class.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,13 +14,17 @@ (in-package "SB-KERNEL") (!begin-collecting-cold-init-forms) +;;; Has the type system been properly initialized? (I.e. is it OK to +;;; use it?) +(define-load-time-global *type-system-initialized* nil) +(!cold-init-forms (setq *type-system-initialized* nil)) ;;;; the CLASSOID structure ;;; The CLASSOID structure is a supertype of all classoid types. ;;; Its definition occurs in 'early-classoid.lisp' #+sb-xc-host -(defmethod sb-xc:make-load-form ((self classoid) &optional env) +(defmethod make-load-form ((self classoid) &optional env) (declare (ignore env)) `(find-classoid ',(classoid-name self))) @@ -31,114 +35,117 @@ ;;; ;;; In each cons, the car is the symbol naming the layout, and the ;;; cdr is the layout itself. -(defvar *!initial-layouts*) +;;; If #+metaspace then the cdr is actually of type WRAPPER, +;;; and if #-metaspace then the wrapper is a LAYOUT. +(defvar *!initial-wrappers*) ;;; a table mapping class names to layouts for classes we have ;;; referenced but not yet loaded. This is initialized from an alist ;;; created by genesis describing the layouts that genesis created at ;;; cold-load time. -(define-load-time-global *forward-referenced-layouts* +(define-load-time-global *forward-referenced-wrappers* ;; FIXME: why is the test EQUAL and not EQ? Aren't the keys all symbols? (make-hash-table :test 'equal)) +#-sb-xc-host (!cold-init-forms - ;; *forward-referenced-layouts* is protected by *WORLD-LOCK* + ;; *forward-referenced-wrappers* is protected by *WORLD-LOCK* ;; so it does not need a :synchronized option. - #-sb-xc-host (progn - (/show0 "processing *!INITIAL-LAYOUTS*") - (setq *forward-referenced-layouts* (make-hash-table :test 'equal)) - (dovector (x *!initial-layouts*) - (let ((expected (hash-layout-name (car x))) - (actual (layout-clos-hash (cdr x)))) - (unless (= actual expected) - (bug "XC layout hash calculation failed"))) - (setf (gethash (car x) *forward-referenced-layouts*) - (cdr x))) - (/show0 "done processing *!INITIAL-LAYOUTS*"))) + (setq *forward-referenced-wrappers* (make-hash-table :test 'equal)) + (dovector (x *!initial-wrappers*) + (let ((expected (hash-layout-name (car x))) + (actual (wrapper-clos-hash (cdr x)))) + (unless (= actual expected) (bug "XC layout hash calculation failed"))) + (setf (gethash (car x) *forward-referenced-wrappers*) (cdr x)))) + +;;; FIXME: This lock is only seized in the classoid/layout/class +;;; system, and is now a misnomer. +#-sb-xc-host +(define-load-time-global **world-lock** nil) +#-sb-xc-host +(!cold-init-forms + (setq **world-lock** (sb-thread:make-mutex :name "World Lock"))) + +(defmacro with-world-lock (() &body body) + #+sb-xc-host `(progn ,@body) + #-sb-xc-host `(sb-thread:with-recursive-lock (**world-lock**) ,@body)) ;;; The LAYOUT structure itself is defined in 'early-classoid.lisp' -(defvar *print-layout-id* t) -(defmethod print-object ((layout layout) stream) - (print-unreadable-object (layout stream :type t :identity t) +#+sb-xc-host +(progn +(defun make-layout (hash classoid &rest keys) + (macrolet ((make (&rest extra) + `(apply #'host-make-wrapper + (cdr (assq (classoid-name classoid) *popular-structure-types*)) + hash classoid ,@extra :allow-other-keys t keys))) + #-metaspace (make) + #+metaspace (let* ((layout (%make-layout)) + (wrapper (make :friend layout))) + (setf (layout-friend layout) wrapper) + wrapper))) +;; The target reconstructs wrappers using FOP-LAYOUT but the host uses MAKE-LOAD-FORM. +(defmethod cl:make-load-form ((wrapper wrapper) &optional env) + (declare (ignore env)) + (labels ((externalize (wrapper &aux (classoid (wrapper-classoid wrapper)) + (name (classoid-name classoid))) + (when (or (wrapper-invalid wrapper) + (not name) + (typep classoid 'undefined-classoid)) + (sb-c:compiler-error "can't dump ~S" wrapper)) + `(xc-load-wrapper ',name + ,(wrapper-depthoid wrapper) + (vector ,@(map 'list #'externalize (wrapper-inherits wrapper))) + ,(wrapper-length wrapper) + ,(wrapper-bitmap wrapper)))) + (externalize wrapper))) +(defun xc-load-wrapper (name depthoid inherits length bitmap) + (let ((classoid (find-classoid name))) + (aver (and classoid (not (undefined-classoid-p classoid)))) + (let ((wrapper (classoid-wrapper classoid))) + (unless (and (= (wrapper-depthoid wrapper) depthoid) + (= (length (wrapper-inherits wrapper)) (length inherits)) + (every #'eq (wrapper-inherits wrapper) inherits) + (= (wrapper-length wrapper) length) + (= (wrapper-bitmap wrapper) bitmap)) + (error "XC can't reload layout for ~S with ~S vs ~A" + name (list depthoid inherits length bitmap) wrapper)) + wrapper))) +) ; end PROGN + +(defmethod print-object ((wrapper wrapper) stream) + (print-unreadable-object (wrapper stream :type t :identity t) (format stream - #+sb-xc-host "for ~S~@[, INVALID=~S~]" - #-sb-xc-host "~@[(ID=~d) ~]for ~S~@[, INVALID=~S~]" - #-sb-xc-host (when *print-layout-id* (layout-id layout)) - (layout-proper-name layout) - (layout-invalid layout)))) + "~@[(ID=~d) ~]for ~S~@[, INVALID=~S~]" + (layout-id wrapper) + (wrapper-proper-name wrapper) + (wrapper-invalid wrapper)))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - (defun layout-proper-name (layout) - (classoid-proper-name (layout-classoid layout)))) + (defun wrapper-proper-name (wrapper) + (classoid-proper-name (wrapper-classoid wrapper)))) ;;; Return the layout currently installed in the classoid named NAME. ;;; If there is none, then make a layout referring for an undefined classoid. -(declaim (ftype (sfunction (symbol) layout) find-layout)) +;;; NB: for #+metaspace this returns a WRAPPER, not a LAYOUT. +(declaim (ftype (sfunction (symbol) wrapper) find-layout)) (defun find-layout (name) (binding* ((classoid (find-classoid name nil) :exit-if-null) ; threadsafe - (layout (classoid-layout classoid) :exit-if-null)) - (return-from find-layout layout)) - (let ((table *forward-referenced-layouts*)) + (wrapper (classoid-wrapper classoid) :exit-if-null)) + (return-from find-layout wrapper)) + (let ((table *forward-referenced-wrappers*)) (with-world-lock () (let ((classoid (find-classoid name nil))) - (or (and classoid (classoid-layout classoid)) + (or (and classoid (classoid-wrapper classoid)) (values (ensure-gethash name table (make-layout (hash-layout-name name) (or classoid (make-undefined-classoid name)))))))))) -;;; In code for the target Lisp, we don't dump LAYOUTs using the -;;; standard load form mechanism, we use special fops instead, in -;;; order to make cold load come out right. But when we're building -;;; the cross-compiler, we can't do that because we don't have access -;;; to special non-ANSI low-level things like special fops, and we -;;; don't need to do that anyway because our code isn't going to be -;;; cold loaded, so we use the ordinary load form system. -#+sb-xc-host -(progn -(defmethod make-load-form ((layout layout) &optional env) - (declare (ignore env)) - (labels ((externalize (layout &aux (classoid (layout-classoid layout)) - (name (classoid-name classoid))) - (when (layout-invalid layout) - (sb-c:compiler-error "can't dump reference to obsolete class: ~S" - (layout-classoid layout))) - (unless name - (sb-c:compiler-error "can't dump anonymous LAYOUT: ~S" layout)) - (aver (= (layout-flags layout) - (typecase classoid - (structure-classoid +structure-layout-flag+) - (condition-classoid +condition-layout-flag+) - (undefined-classoid - (bug "xc MAKE-LOAD-FORM on undefined layout")) - (t 0)))) - `(xc-load-layout ',name - ,(layout-depthoid layout) - (vector ,@(map 'list #'externalize (layout-inherits layout))) - ,(layout-length layout) - ,(layout-bitmap layout) - ,(layout-flags layout)))) - (externalize layout))) -(defun xc-load-layout (name depthoid inherits length bitmap flags) - (let ((classoid (find-classoid name))) - (aver (and classoid (not (undefined-classoid-p classoid)))) - (let ((layout (classoid-layout classoid))) - (aver layout) - (unless (and (= (layout-depthoid layout) depthoid) - (= (length (layout-inherits layout)) (length inherits)) - (every #'eq (layout-inherits layout) inherits) - (= (layout-length layout) length) - (= (layout-bitmap layout) bitmap) - (= (layout-flags layout) flags)) - (error "XC can't reload layout for ~S with ~S vs ~A" - name (list depthoid inherits length bitmap flags) layout)) - layout)))) - ;;; If LAYOUT's slot values differ from the specified slot values in ;;; any interesting way, then give a warning and return T. (declaim (ftype (function (simple-string - layout + wrapper simple-string index simple-vector @@ -147,18 +154,17 @@ warn-if-altered-layout)) (defun warn-if-altered-layout (old-context old-layout context length inherits depthoid bitmap) - (declare (type layout old-layout) (type simple-string old-context context)) - (let ((name (layout-proper-name old-layout)) - (old-inherits (layout-inherits old-layout))) - (or (when (mismatch old-inherits inherits :key #'layout-proper-name) + (let ((name (wrapper-proper-name old-layout)) + (old-inherits (wrapper-inherits old-layout))) + (or (when (mismatch old-inherits inherits :key #'wrapper-proper-name) (warn "change in superclasses of class ~S:~% ~ ~A superclasses: ~S~% ~ ~A superclasses: ~S" name old-context - (map 'list #'layout-proper-name old-inherits) + (map 'list #'wrapper-proper-name old-inherits) context - (map 'list #'layout-proper-name inherits)) + (map 'list #'wrapper-proper-name inherits)) t) (let ((diff (mismatch old-inherits inherits))) (when diff @@ -167,10 +173,10 @@ ~A definition." name old-context - (layout-proper-name (svref old-inherits diff)) + (wrapper-proper-name (svref old-inherits diff)) context) t)) - (let ((old-length (layout-length old-layout))) + (let ((old-length (wrapper-length old-layout))) (unless (= old-length length) (warn "change in instance length of class ~S:~% ~ ~A length: ~W~% ~ @@ -179,13 +185,13 @@ old-context old-length context length) t)) - (let ((old-bitmap (layout-bitmap old-layout))) + (let ((old-bitmap (wrapper-bitmap old-layout))) (unless (= old-bitmap bitmap) (warn "change in placement of raw slots of class ~S ~ between the ~A definition and the ~A definition" name old-context context) t)) - (unless (= (layout-depthoid old-layout) depthoid) + (unless (= (wrapper-depthoid old-layout) depthoid) (warn "change in the inheritance structure of class ~S~% ~ between the ~A definition and the ~A definition" name old-context context) @@ -194,11 +200,11 @@ (defun load-layout (name depthoid inherits length bitmap flags) (let* ((layout (or (binding* ((classoid (find-classoid name nil) :exit-if-null)) - (classoid-layout classoid)) - (let ((table *forward-referenced-layouts*)) + (classoid-wrapper classoid)) + (let ((table *forward-referenced-wrappers*)) (with-world-lock () (let ((classoid (find-classoid name nil))) - (or (and classoid (classoid-layout classoid)) + (or (and classoid (classoid-wrapper classoid)) (ensure-gethash name table (make-layout @@ -207,10 +213,10 @@ :depthoid depthoid :inherits inherits :length length :bitmap bitmap :flags flags)))))))) (classoid - (or (find-classoid name nil) (layout-classoid layout)))) - (if (or (eq (layout-invalid layout) :uninitialized) + (or (find-classoid name nil) (wrapper-classoid layout)))) + (if (or (eq (wrapper-invalid layout) :uninitialized) (not *type-system-initialized*)) - (setf (layout-classoid layout) classoid) + (setf (wrapper-classoid layout) classoid) ;; There was an old layout already initialized with old ;; information, and we'll now check that old information ;; which was known with certainty is consistent with current @@ -218,9 +224,87 @@ (when (warn-if-altered-layout "current" layout "compile time" length inherits depthoid bitmap) (error "The loaded code expects an incompatible layout for class ~S." - (layout-proper-name layout)))) + (wrapper-proper-name layout)))) layout)) +(defun classoid-lock (classoid) + #+sb-xc-host (declare (ignore classoid)) + #-sb-xc-host + (or (classoid-%lock classoid) + (let* ((lock (sb-thread:make-mutex :name "classoid lock")) + (oldval (cas (classoid-%lock classoid) nil lock))) + (if (eq oldval nil) lock oldval)))) + +(defun add-subclassoid (super sub wrapper) + (with-system-mutex ((classoid-lock super)) + (let ((table (classoid-subclasses super))) + (block nil + (when (hash-table-p table) + (return (setf (gethash sub table) wrapper))) + (let ((count 0)) + (dolist (cell table) + (when (eq (car cell) sub) + (return (setf (cdr cell) wrapper))) + (incf (truly-the fixnum count))) + (when (<= count 7) + (setf (classoid-subclasses super) (acons sub wrapper table)) + (sb-thread:barrier (:write)) + (return wrapper))) + ;; Upgrade to a hash-table + (let ((new #+sb-xc-host (make-hash-table :test 'eq) + #-sb-xc-host (make-hash-table :hash-function #'type-hash-value + :test 'eq))) + (loop for (key . val) in table do (setf (gethash key new) val)) + (setf (gethash sub new) wrapper) + (setf (classoid-subclasses super) new) + (sb-thread:barrier (:write)) + wrapper))))) + +;;; Mnemonic device: the argument order is as GETHASH (1st = key, 2nd = table). +;;; But the 2nd arg is the superclassoid, *not* its subclassoid table, +;;; because the mutex is stored in the classoid, not the table. +(defun get-subclassoid (sub super) + (sb-thread:barrier (:read)) + (when (classoid-subclasses super) + (with-system-mutex ((classoid-lock super)) + (let ((table (classoid-subclasses super))) + (cond ((listp table) (cdr (assq sub table))) + (t (values (gethash sub table)))))))) + +;;; Mnemonic device: it's like REMHASH (1st = key, 2nd = table) +(defun remove-subclassoid (sub super) + (sb-thread:barrier (:read)) + (when (classoid-subclasses super) + (with-system-mutex ((classoid-lock super)) + (let ((table (classoid-subclasses super))) + (cond ((listp table) + (setf (classoid-subclasses super) + (delete sub table :key #'car :test #'eq))) + (t + ;; There's no reason to demote a table to a list ever. + (remhash sub table)))))) + nil) + +(defmacro do-subclassoids (((classoid-var wrapper-var) super) &body body) + (let ((f (make-symbol "FUNCTION"))) + `(dx-flet ((,f (,classoid-var ,wrapper-var) ,@body)) + (call-with-subclassoids #',f (the classoid ,super))))) + +(defun call-with-subclassoids (function super &aux (table (classoid-subclasses super))) + ;; Uses of DO-SUBCLASSOIDS don't need to acquire the classoid lock on SUPER. + ;; Even if there are readers or writers, hash-table iteration is safe. + ;; This was not always so - iteration could overrun the k/v array because it always + ;; re-fetched the scan limit, which could see a higher limit than corresponded + ;; to the k/v vector that it had gotten initially. + ;; If you're doing concurrent modification of the class heterarchy, there are no + ;; real guarantees. We dont' always hold a lock at a wider scope than the table lock, + ;; but sometimes we do, such as in REGISTER-LAYOUT. + (if (listp table) + (loop for (key . value) in table do (funcall function key value)) + (maphash (lambda (key value) (funcall function key value)) + table)) + nil) + ;;; Record LAYOUT as the layout for its class, adding it as a subtype ;;; of all superclasses. This is the operation that "installs" a ;;; layout for a class in the type system, clobbering any old layout. @@ -230,13 +314,21 @@ ;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared. ;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be ;;; destructively modified to hold the same type information. -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) -(defun register-layout (layout &key (invalidate t) destruct-layout) - (declare (type layout layout) (type (or layout null) destruct-layout)) +(macrolet ((set-bitmap-from-layout (to-layout from-layout) + `(let ((to-index + (+ (type-dd-length sb-vm:layout) + (calculate-extra-id-words (layout-depthoid ,to-layout)))) + (from-index + (+ (type-dd-length sb-vm:layout) + (calculate-extra-id-words (layout-depthoid ,from-layout))))) + (dotimes (i (bitmap-nwords ,from-layout)) + (%raw-instance-set/word ,to-layout (+ to-index i) + (%raw-instance-ref/word ,from-layout (+ from-index i))))))) +(defun register-layout (wrapper &key (invalidate t) modify) + (declare (type wrapper wrapper) (type (or wrapper null) modify)) (with-world-lock () - (let* ((classoid (layout-classoid layout)) - (classoid-layout (classoid-layout classoid)) - (subclasses (classoid-subclasses classoid))) + (let* ((classoid (wrapper-classoid wrapper)) + (classoid-wrapper (classoid-wrapper classoid))) ;; Attempting to register ourselves with a temporary undefined ;; class placeholder is almost certainly a programmer error. (I @@ -246,32 +338,32 @@ ;; This assertion dates from classic CMU CL. The rationale is ;; probably that calling REGISTER-LAYOUT more than once for the ;; same LAYOUT is almost certainly a programmer error. - (aver (not (eq classoid-layout layout))) + (aver (not (eq classoid-wrapper wrapper))) ;; Figure out what classes are affected by the change, and issue ;; appropriate warnings and invalidations. - (when classoid-layout + (when classoid-wrapper (%modify-classoid classoid) - (when subclasses - (dohash ((subclass subclass-layout) subclasses :locked t) + (do-subclassoids ((subclass subclass-wrapper) classoid) ; under WORLD-LOCK (%modify-classoid subclass) (when invalidate - (%invalidate-layout subclass-layout)))) + (%invalidate-layout subclass-wrapper))) (when invalidate - (%invalidate-layout classoid-layout) + (%invalidate-layout classoid-wrapper) (setf (classoid-subclasses classoid) nil))) - (if destruct-layout + (if modify #+sb-xc-host (error "Why mutate a layout in XC host?") #-sb-xc-host ;; Destructively modifying a layout is not threadsafe at all. ;; Use at your own risk (interactive use only). - (let ((inherits (layout-inherits layout)) - (depthoid (layout-depthoid layout)) ; "new" depthoid + (let ((inherits (wrapper-inherits wrapper)) + (depthoid (wrapper-depthoid wrapper)) ; "new" depthoid (extra-id-words ; "old" extra words - (calculate-extra-id-words (layout-depthoid destruct-layout))) + (calculate-extra-id-words (wrapper-depthoid modify))) + (layout (wrapper-friend wrapper)) (id ; read my ID before screwing with the depthoid - (layout-id destruct-layout))) + (layout-id modify))) (aver (logtest +structure-layout-flag+ (layout-flags layout))) (aver (= (length inherits) depthoid)) ;; DEPTHOID implies the number of words of "extra" IDs preceding the bitmap. @@ -280,10 +372,10 @@ ;; again to be certain. Heap corruption is the greater evil versus a minor ;; inconvenience of not offering the RECKLESSLY-CONTINUE restart. (aver (= (calculate-extra-id-words depthoid) extra-id-words)) - #-64-bit (setf (layout-depthoid destruct-layout) (layout-depthoid layout) - (layout-length destruct-layout) (layout-length layout)) - (setf (layout-flags destruct-layout) (layout-flags layout) - (layout-info destruct-layout) (layout-info layout)) + #-64-bit (setf (wrapper-depthoid modify) (wrapper-depthoid wrapper) + (wrapper-length modify) (wrapper-length wrapper)) + (setf (layout-flags (wrapper-friend modify)) (layout-flags layout) + (wrapper-info modify) (wrapper-info wrapper)) ;; Zero out the inherited ID values one word at a time. ;; This makes self-ID transiently disappear, but what else can we do? ;; It's may be in the wrong slot anyway, depending on whether depthoid changed. @@ -291,38 +383,28 @@ ;; (/ (- (1+ layout-id-vector-fixed-capacity) 2) number-of-ids-per-word) ;; which is surely more confusing than spelling it as 3 or 6. (dotimes (i (+ extra-id-words #+64-bit 3 #-64-bit 6)) - (setf (%raw-instance-ref/word destruct-layout - (+ (get-dsd-index layout id-word0) i)) - 0)) - (set-layout-inherits destruct-layout inherits t id) - (set-bitmap-from-layout destruct-layout layout) - (setf (layout-invalid destruct-layout) nil - (classoid-layout classoid) destruct-layout)) - (setf (layout-invalid layout) nil - (classoid-layout classoid) layout)) - - (dovector (super-layout (layout-inherits layout)) - (let* ((super (layout-classoid super-layout)) - (subclasses - (or (classoid-subclasses super) - (setf (classoid-subclasses super) - #+sb-xc-host (make-hash-table :test 'eq) - ;; Might as well use CTYPE-HASH-VALUE as a - ;; stable hash since we have it. - #-sb-xc-host - (make-hash-table :hash-function #'type-hash-value - :test 'eq - :synchronized t))))) + (%raw-instance-set/word (wrapper-friend modify) + (+ (get-dsd-index sb-vm:layout id-word0) i) + 0)) + (set-layout-inherits modify inherits t id) + (let ((dst (wrapper-friend modify)) + (src (wrapper-friend wrapper))) + (set-bitmap-from-layout dst src)) + (setf (wrapper-invalid modify) nil + (classoid-wrapper classoid) modify)) + (setf (wrapper-invalid wrapper) nil + (classoid-wrapper classoid) wrapper)) + + (dovector (super-wrapper (wrapper-inherits wrapper)) + (let ((super (wrapper-classoid super-wrapper))) (when (and (eq (classoid-state super) :sealed) - (not (gethash classoid subclasses))) + (not (get-subclassoid classoid super))) (warn "unsealing sealed class ~S in order to subclass it" (classoid-name super)) (setf (classoid-state super) :read-only)) - (setf (gethash classoid subclasses) - (or destruct-layout layout)))))) + (add-subclassoid super classoid (or modify wrapper)))))) - (values)) -); EVAL-WHEN + (values))) ;;; Arrange the inherited layouts to appear at their expected depth, ;;; ensuring that hierarchical type tests succeed. Layouts with @@ -351,7 +433,7 @@ (let ((length (length layouts)) (max-depth -1)) (dotimes (i length) - (let ((depth (layout-depthoid (svref layouts i)))) + (let ((depth (wrapper-depthoid (svref layouts i)))) (when (> depth max-depth) (setf max-depth depth)))) (let* ((new-length (max (1+ max-depth) length)) @@ -362,7 +444,7 @@ (inherits (make-array new-length :initial-element 0))) (dotimes (i length) (let* ((layout (svref layouts i)) - (depth (layout-depthoid layout))) + (depth (wrapper-depthoid layout))) (unless (eql depth -1) (let ((old-layout (svref inherits depth))) (unless (or (eql old-layout 0) (eq old-layout layout)) @@ -373,7 +455,7 @@ ((>= i length)) (declare (type index i j)) (let* ((layout (svref layouts i)) - (depth (layout-depthoid layout))) + (depth (wrapper-depthoid layout))) (when (eql depth -1) (loop (when (eql (svref inherits j) 0) (return)) @@ -455,29 +537,48 @@ (note-class class) (topological-sort classes constraints #'std-cpl-tie-breaker)))) -;;;; object types to represent classes -;;; BUILT-IN-CLASS is used to represent the standard classes that -;;; aren't defined with DEFSTRUCT and other specially implemented -;;; primitive types whose only attribute is their name. -;;; It is defined in 'early-classoid.lisp' - -;;; STRUCTURE-CLASS represents what we need to know about structure -;;; classes. Non-structure "typed" defstructs are a special case, and -;;; don't have a corresponding class. -(def!struct (structure-classoid (:include classoid) - (:copier nil) - (:constructor make-structure-classoid - (&key name &aux (%bits (pack-ctype-bits classoid name)))))) +;;; Return the layout for an object. This is the basic operation for +;;; finding out the "type" of an object, and is used for generic +;;; function dispatch. The standard doesn't seem to say as much as it +;;; should about what this returns for built-in objects. For example, +;;; it seems that we must return NULL rather than LIST when X is NIL +;;; so that GF's can specialize on NULL. +;;; x86-64 has a vop that implements this without even needing to place +;;; the vector of layouts in the constant pool of the containing code. +#-(or sb-xc-host (and compact-instance-header x86-64)) +(progn +(declaim (inline wrapper-of)) +(defun wrapper-of (x) + (declare (optimize (speed 3) (safety 0))) + (cond ((%instancep x) (%instance-wrapper x)) + ((funcallable-instance-p x) (%fun-wrapper x)) + ;; Compiler can dump literal layouts, which handily sidesteps + ;; the question of when cold-init runs L-T-V forms. + ((null x) #.(find-layout 'null)) + (t + ;; Note that WIDETAG-OF is slightly suboptimal here and could be + ;; improved - we've already ruled out some of the lowtags. + (layout-friend + (svref (load-time-value **primitive-object-layouts** t) + (widetag-of x))))))) + +#-sb-xc-host +(progn +(declaim (inline classoid-of)) +(defun classoid-of (object) + "Return the class of the supplied object, which may be any Lisp object, not + just a CLOS STANDARD-OBJECT." + (wrapper-classoid (wrapper-of object)))) + ;;;; classoid namespace (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun (setf find-classoid) (new-value name) - #-sb-xc (declare (type (or null classoid) new-value)) + (declare (type (or null classoid) new-value)) (aver new-value) - (let ((table *forward-referenced-layouts*)) - (with-world-lock () + (with-world-lock () (let ((cell (find-classoid-cell name :create t))) (ecase (info :type :kind name) ((nil)) @@ -521,7 +622,7 @@ (clear-info :type :expander name) (clear-info :type :source-location name))) - (remhash name table) + (remhash name *forward-referenced-wrappers*) (%note-type-defined name) ;; FIXME: I'm unconvinced of the need to handle either of these. ;; Package locks preclude the latter, and in the former case, @@ -543,9 +644,9 @@ (setf (info :type :kind name) :instance))) (setf (classoid-cell-classoid cell) new-value) (unless (eq (info :type :compiler-layout name) - (classoid-layout new-value)) + (classoid-wrapper new-value)) (setf (info :type :compiler-layout name) - (classoid-layout new-value)))))) + (classoid-wrapper new-value))))) new-value) (defun %clear-classoid (name cell) @@ -576,6 +677,26 @@ (clear-info :type :compiler-layout name) (values-specifier-type-cache-clear))))) +(defun find-classoid-cell (name &key create) + (let ((real-name (uncross name))) + (cond ((info :type :classoid-cell real-name)) + (create + (get-info-value-initializing :type :classoid-cell real-name + (make-classoid-cell real-name)))))) + +;;; Return the classoid with the specified NAME. If ERRORP is false, +;;; then NIL is returned when no such class exists. +(defun find-classoid (name &optional (errorp t)) + (declare (type symbol name)) + (let ((cell (find-classoid-cell name))) + (cond ((and cell (classoid-cell-classoid cell))) + (errorp + (error 'simple-type-error + :datum nil + :expected-type 'class + :format-control "Class not yet defined: ~S" + :format-arguments (list name)))))) + ;;; Called when we are about to define NAME as a class meeting some ;;; predicate (such as a meta-class type test.) The first result is ;;; always of the desired class. The second result is any existing @@ -586,22 +707,22 @@ (defun insured-find-classoid (name predicate constructor) (declare (type function predicate) (type (or function symbol) constructor)) - (let ((table *forward-referenced-layouts*)) + (let ((table *forward-referenced-wrappers*)) (with-system-mutex ((hash-table-lock table)) (let* ((old (find-classoid name nil)) (res (if (and old (funcall predicate old)) old (funcall constructor :name name))) (found (or (gethash name table) - (when old (classoid-layout old))))) + (when old (classoid-wrapper old))))) (when found - (setf (layout-classoid found) res)) + (setf (wrapper-classoid found) res)) (values res found))))) ;;; If the classoid has a proper name, return the name, otherwise return ;;; the classoid. (defun classoid-proper-name (classoid) - #-sb-xc (declare (type classoid classoid)) + (declare (type classoid classoid)) (let ((name (classoid-name classoid))) (if (and name (eq (find-classoid name nil) classoid)) name @@ -632,16 +753,16 @@ (let ((super (if (symbolp super-or-name) (find-classoid super-or-name) super-or-name))) - (find (classoid-layout super) - (layout-inherits (classoid-layout sub))))) + (find (classoid-wrapper super) + (wrapper-inherits (classoid-wrapper sub))))) ;;; We might be passed classoids with invalid layouts; in any pairwise ;;; class comparison, we must ensure that both are valid before ;;; proceeding. (defun %ensure-classoid-valid (classoid layout error-context) (declare (ignorable error-context)) ; not used on host - (aver (eq classoid (layout-classoid layout))) - (or (not (layout-invalid layout)) + (aver (eq classoid (wrapper-classoid layout))) + (or (not (wrapper-invalid layout)) ;; Avoid accidentally reaching code that can't work. #+sb-xc-host (bug "(TYPEP x 'STANDARD-CLASSOID) can't be tested") #-sb-xc-host @@ -667,10 +788,10 @@ classoid (or error-context 'subtypep))))) (defun %ensure-both-classoids-valid (class1 class2 &optional errorp) - (do ((layout1 (classoid-layout class1) (classoid-layout class1)) - (layout2 (classoid-layout class2) (classoid-layout class2)) + (do ((layout1 (classoid-wrapper class1) (classoid-wrapper class1)) + (layout2 (classoid-wrapper class2) (classoid-wrapper class2)) (i 0 (+ i 1))) - ((and (not (layout-invalid layout1)) (not (layout-invalid layout2))) + ((and (not (wrapper-invalid layout1)) (not (wrapper-invalid layout2))) t) (aver (< i 2)) (unless (and (%ensure-classoid-valid class1 layout1 errorp) @@ -686,10 +807,10 @@ (define-type-method (classoid :simple-subtypep) (class1 class2) (aver (not (eq class1 class2))) - (with-world-lock () + (with-world-lock () ; FIXME: why such coarse lock granularity here? (if (%ensure-both-classoids-valid class1 class2) - (let ((subclasses2 (classoid-subclasses class2))) - (if (and subclasses2 (gethash class1 subclasses2)) + (let () + (if (get-subclassoid class1 class2) (values t t) (if (and (typep class1 'standard-classoid) (typep class2 'standard-classoid) @@ -712,10 +833,12 @@ (let ((s-sub (classoid-subclasses sealed)) (o-sub (classoid-subclasses other))) (if (and s-sub o-sub) + ;; FIXME: should we put more locking here? + ;; [contrast with define-type-method (classoid :simple-subtypep)] (collect ((res *empty-type* type-union)) - (dohash ((subclass layout) s-sub :locked t) - (declare (ignore layout)) - (when (gethash subclass o-sub) + (do-subclassoids ((subclass wrapper) sealed) + (declare (ignore wrapper)) + (when (get-subclassoid subclass other) (res (specifier-type subclass)))) (res)) *empty-type*))) @@ -728,12 +851,8 @@ class1) ;; If one is a subclass of the other, then that is the ;; intersection. - ((let ((subclasses (classoid-subclasses class2))) - (and subclasses (gethash class1 subclasses))) - class1) - ((let ((subclasses (classoid-subclasses class1))) - (and subclasses (gethash class2 subclasses))) - class2) + ((get-subclassoid class1 class2) class1) + ((get-subclassoid class2 class1) class2) ;; Otherwise, we can't in general be sure that the ;; intersection is empty, since a subclass of both might be ;; defined. But we can eliminate it for some special cases. @@ -767,7 +886,7 @@ (declaim (type cons **non-instance-classoid-types**)) (defglobal **non-instance-classoid-types** '(symbol system-area-pointer weak-pointer code-component - #-(or x86 x86-64) lra + #-(or x86 x86-64 arm64) lra fdefn random-class)) (defun classoid-non-instance-p (classoid) @@ -829,32 +948,39 @@ ;;; List of the direct superclasses of this class. ;;; ;;; NB: not to be confused with SB-PCL::*BUILT-IN-CLASSES* -(defconstant-eqx +!built-in-classes+ - ;; constant-quasiquote-form-p is not smart enough to notice - ;; that this entire thing is constant, so we kind of have to force it. -'#.`((t :state :read-only :translation t) +;;; (note the difference in spelling, to help keep things unconfusing) +#+sb-xc-host +(defvar *builtin-classoids* + `((t :state :read-only :translation t) (character :codes (,sb-vm:character-widetag) :translation (character-set) :prototype-form (code-char 42)) (symbol :codes (,sb-vm:symbol-widetag) + :predicate symbolp :prototype-form '*) (system-area-pointer :codes (,sb-vm:sap-widetag) + :predicate system-area-pointer-p :prototype-form (int-sap 0)) (weak-pointer :codes (,sb-vm:weak-pointer-widetag) - :prototype-form (make-weak-pointer 0)) + :predicate weak-pointer-p + :prototype-form (make-weak-pointer 0)) (code-component :codes (,sb-vm:code-header-widetag) + :predicate code-component-p :prototype-form (fun-code-header #'identity)) - #-(or x86 x86-64) (lra :codes (,sb-vm:return-pc-widetag) - ;; Make the PROTOTYPE slot unbound. - :prototype-form sb-pcl:+slot-unbound+) + #-(or x86 x86-64 arm64) (lra :codes (,sb-vm:return-pc-widetag) + :predicate lra-p + ;; Make the PROTOTYPE slot unbound. + :prototype-form sb-pcl:+slot-unbound+) (fdefn :codes (,sb-vm:fdefn-widetag) + :predicate fdefn-p :prototype-form (find-or-create-fdefn 'sb-mop:class-prototype)) (random-class ; used for unknown type codes ;; Make the PROTOTYPE slot unbound. :prototype-form sb-pcl:+slot-unbound+) (function :codes (,sb-vm:closure-widetag ,sb-vm:simple-fun-widetag) + :predicate functionp :state :read-only :prototype-form #'identity) @@ -1027,11 +1153,20 @@ :direct-superclasses (symbol list) :prototype-form 'nil) + (sb-pcl::slot-object + :translation (or structure-object standard-object condition) + :predicate slot-object-p + :hierarchical-p nil + :state :read-only + :prototype-form (make-defstruct-description t 'arbitrary)) + ;; KLUDGE: the length must match the subsequent defstruct. (pathname :depth 1 + :predicate pathnamep :length ,(+ 7 sb-vm:instance-data-start) :prototype-form (make-pathname)) (logical-pathname :depth 2 + :predicate logical-pathname-p :length ,(+ 7 sb-vm:instance-data-start) :prototype-form (make-pathname :host "SYS") :inherits (pathname)) @@ -1044,7 +1179,7 @@ ;; ;; Essentially the hardwiring corresponds to the indices of the ;; respective types in the inherits vector for FD-STREAM. - ;; * (layout-inherits (find-layout 'fd-stream)) + ;; * (wrapper-inherits (find-layout 'fd-stream)) ;; #(# ;; # ;; # @@ -1052,13 +1187,16 @@ ;; #) (stream + :predicate streamp :state :read-only :depth 2) (file-stream + :predicate file-stream-p :state :read-only :depth 4 :inherits (stream)) (string-stream + :predicate string-stream-p :state :read-only :depth 4 :inherits (stream)) @@ -1076,81 +1214,114 @@ :inherits (vector simple-array array sequence) :prototype-form (logically-readonlyize - (make-array 0 :element-type ',(sb-vm:saetp-specifier x)))))) - #'equal) + (make-array 0 :element-type ',(sb-vm:saetp-specifier x))))))) + +(eval-when (#-sb-xc-host :compile-toplevel) + (defun compute-builtin-classoids () + (mapcar (lambda (x) + (let* ((name (car x)) + (classoid (find-classoid name)) + (translation (built-in-classoid-translation classoid)) + (predicate + (if (member name '(t random-class)) + 'error + (or (getf (cdr x) :predicate) + (sb-c::backend-type-predicate translation))))) + (assert predicate) + ;; destructuring-bind will see the first :translation + ;; keyword; we don't need to delete the other one. + (list* name :predicate predicate :translation translation (cdr x)))) + *builtin-classoids*))) + +;;; The read interceptor has to be disabled to avoid infinite recursion on CTYPEs +(eval-when (:compile-toplevel) (setq sb-cold::*choke-on-host-irrationals* nil)) +#-sb-xc-host +(define-load-time-global *builtin-classoids* nil) +#-sb-xc-host +(!cold-init-forms + (setq *builtin-classoids* '#.(compute-builtin-classoids))) +(eval-when (:compile-toplevel) (setq sb-cold::*choke-on-host-irrationals* t)) -;;; See also src/code/class-init.lisp where we finish setting up the +;;; See also src/code/type-init.lisp where we finish setting up the ;;; translations for built-in types. (!cold-init-forms - (dolist (x +!built-in-classes+) - #-sb-xc-host (/show0 "at head of loop over +!BUILT-IN-CLASSES+") - (destructuring-bind - (name &key - (translation nil trans-p) - inherits - codes - state - depth - (length 0) - prototype-form - (hierarchical-p t) ; might be modified below - (direct-superclasses (if inherits - (list (car inherits)) - '(t)))) - x - (declare (ignore codes state translation)) - ;; instance metatypes and T don't need a prototype, everything else does - (unless (or prototype-form depth (eq name 't)) - (error "Missing prototype in ~S" x)) - (let ((inherits-list (if (eq name t) + (dolist (x *builtin-classoids*) + #-sb-xc-host (/show0 "at head of loop over *BUILTIN-CLASSOIDS*") + (destructuring-bind + (name &key + (translation nil trans-p) + predicate + inherits + codes + state + depth + (length 0) + prototype-form + (hierarchical-p t) ; might be modified below + (direct-superclasses (if inherits + (list (car inherits)) + '(t)))) + x + (declare (ignorable codes state translation trans-p predicate)) + ;; instance metatypes and T don't need a prototype, everything else does + (unless (or prototype-form depth (eq name 't)) + (error "Missing prototype in ~S" x)) + (let* ((pred-fn (if (fboundp predicate) (symbol-function predicate) #'error)) + (inherits-list (if (eq name t) () (cons t (reverse inherits)))) (classoid - (acond #+sb-xc ; genesis dumps some classoid literals - ((find-classoid name nil) - ;; Unseal it so that REGISTER-LAYOUT doesn't warn - (setf (classoid-state it) nil) - it) - (t - (setf (classoid-cell-classoid - (find-classoid-cell name :create t)) - (!make-built-in-classoid + (acond #-sb-xc-host ; genesis dumps some classoid literals + ((find-classoid name nil) + (%instance-set it (get-dsd-index built-in-classoid predicate) + pred-fn) + ;; Unseal it so that REGISTER-LAYOUT doesn't warn + (setf (classoid-state it) nil) + it) + (t + (setf (classoid-cell-classoid + (find-classoid-cell name :create t)) + (!make-built-in-classoid :%bits (pack-ctype-bits classoid name) :name name - :translation (if trans-p :initializing nil) + :translation #+sb-xc-host (if trans-p :initializing nil) + #-sb-xc-host translation + :allow-other-keys t :predicate pred-fn :direct-superclasses (if (eq name t) nil (mapcar #'find-classoid direct-superclasses)))))))) - (setf (info :type :kind name) :primitive) - (unless trans-p - (setf (info :type :builtin name) classoid)) - (let* ((inherits-vector + (setf (info :type :kind name) :primitive) + #+sb-xc-host + (unless trans-p + (setf (info :type :builtin name) classoid)) + #-sb-xc-host (setf (info :type :builtin name) (or translation classoid)) + (let* ((inherits-vector (map 'simple-vector (lambda (x) (let ((super-layout - (classoid-layout (find-classoid x)))) - (when (minusp (layout-depthoid super-layout)) + (classoid-wrapper (find-classoid x)))) + (when (minusp (wrapper-depthoid super-layout)) (setf hierarchical-p nil)) super-layout)) inherits-list)) - (depthoid (if hierarchical-p - (or depth (length inherits-vector)) - -1))) - (register-layout (load-layout name - depthoid - inherits-vector - length - +layout-all-tagged+ - 0) ; flags - :invalidate nil))))) - (/show0 "done with loop over +!BUILT-IN-CLASSES+")) + (depthoid (if hierarchical-p + (or depth (length inherits-vector)) + -1))) + (register-layout (load-layout name + depthoid + inherits-vector + length + +layout-all-tagged+ + 0) ; flags + :invalidate nil))))) + (/show0 "done with loop over *!BUILTIN-CLASSOIDS*")) -;;; Now that we have set up the class heterarchy, seal the sealed +;;; Now that we have set up the class hierarchy, seal the sealed ;;; classes. This must be done after the subclasses have been set up. (!cold-init-forms - (dolist (x +!built-in-classes+) + (dolist (x *builtin-classoids*) (destructuring-bind (name &key (state :sealed) &allow-other-keys) x (setf (classoid-state (find-classoid name)) state)))) @@ -1174,21 +1345,22 @@ ;;; nominal superclasses.) We set the layout-clos-hash slots to 0 to ;;; invalidate the wrappers for specialized dispatch functions, which ;;; use those slots as indexes into tables. -(defun %invalidate-layout (layout) - (declare (type layout layout)) - #+sb-xc-host (warn "Why are we invalidating layout ~S?" layout) - (setf (layout-invalid layout) t) - ;; Ensure that the INVALID slot conveying ancillary data describing the - ;; invalidity reason is published before causing the invalid layout trap. - (sb-thread:barrier (:write)) - (setf (layout-clos-hash layout) 0) - (let ((inherits (layout-inherits layout)) - (classoid (layout-classoid layout))) - (%modify-classoid classoid) - (dovector (super inherits) - (let ((subs (classoid-subclasses (layout-classoid super)))) - (when subs - (remhash classoid subs))))) +(defun %invalidate-layout (wrapper) + (declare (type wrapper wrapper)) + #+sb-xc-host (error "Can't invalidate layout ~S" wrapper) + #-sb-xc-host + (progn + (setf (wrapper-invalid wrapper) t) + ;; Ensure that the INVALID slot conveying ancillary data describing the + ;; invalidity reason is published before causing the invalid layout trap. + (sb-thread:barrier (:write)) + #+metaspace (setf (layout-clos-hash (wrapper-friend wrapper)) 0) + (setf (wrapper-clos-hash wrapper) 0) + (let ((inherits (wrapper-inherits wrapper)) + (classoid (wrapper-classoid wrapper))) + (%modify-classoid classoid) + (dovector (super inherits) + (remove-subclassoid classoid (wrapper-classoid super))))) (values)) ;;;; cold loading initializations @@ -1199,14 +1371,14 @@ ;;; late in the build-order.lisp-expr sequence, and be put in ;;; !COLD-INIT-FORMS there? (defun !class-finalize () - (dohash ((name layout) *forward-referenced-layouts*) + (dohash ((name wrapper) *forward-referenced-wrappers*) (let ((class (find-classoid name nil))) (cond ((not class) - (setf (layout-classoid layout) (make-undefined-classoid name))) - ((eq (classoid-layout class) layout) - (remhash name *forward-referenced-layouts*)) + (error "How is there no classoid for ~S ?" name)) + ((eq (classoid-wrapper class) wrapper) + (remhash name *forward-referenced-wrappers*)) (t (error "Something strange with forward layout for ~S:~% ~S" - name layout)))))) + name wrapper)))))) (!defun-from-collected-cold-init-forms !classes-cold-init) diff -Nru sbcl-2.1.1/src/code/cl-specials.lisp sbcl-2.1.11/src/code/cl-specials.lisp --- sbcl-2.1.1/src/code/cl-specials.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cl-specials.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -217,3 +217,17 @@ (if (%boundp ',name) (make-unbound-marker) ,value) (sb-c:source-location) ,@(and docp `(',doc))))) + +;;; Ensure some VM symbols get wired TLS. +(in-package "SB-VM") +(eval-when (:compile-toplevel :load-toplevel :execute) + (dolist (entry '#.per-thread-c-interface-symbols) + (let ((symbol (if (consp entry) (car entry) entry))) + (declare (notinline sb-int:info (setf sb-int:info))) + ;; CURRENT-{CATCH/UWP}-BLOCK are thread slots, + ;; so the TLS indices were already assigned. + ;; There may be other symbols too. + (unless (sb-int:info :variable :wired-tls symbol) + (setf (sb-int:info :variable :wired-tls symbol) :always-thread-local)) + (unless (sb-int:info :variable :always-bound symbol) + (setf (sb-int:info :variable :always-bound symbol) :always-bound))))) diff -Nru sbcl-2.1.1/src/code/cmacros.lisp sbcl-2.1.11/src/code/cmacros.lisp --- sbcl-2.1.1/src/code/cmacros.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cmacros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -37,13 +37,6 @@ eof-error-p 'read-from-string) t))) -(eval-when (:compile-toplevel :execute) - (setf (sb-int:info :function :kind 'sb-c:policy) :macro - (sb-int:info :function :macro-function 'sb-c:policy) - (lambda (form env) - (declare (ignore env)) - (values (cl:macroexpand-1 form nil))))) - (define-compiler-macro read-from-string (&whole form string &rest args &environment env) ;; Check this at compile-time, and rewrite it so we're silent at runtime. diff -Nru sbcl-2.1.1/src/code/cold-error.lisp sbcl-2.1.11/src/code/cold-error.lisp --- sbcl-2.1.1/src/code/cold-error.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cold-error.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,7 +11,7 @@ (in-package "SB-KERNEL") -(defparameter *break-on-signals* nil ; initialized by genesis +(defvar *break-on-signals* nil "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will enter the debugger prior to signalling that condition.") @@ -115,7 +115,7 @@ ;;; counts of nested errors (with internal errors double-counted) (defvar *maximum-error-depth*) ; this gets set to 10 in !COLD-INIT -(defparameter *current-error-depth* 0) ; initialized by genesis +(defvar *current-error-depth* 0) ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out ;;; of hyperspace. @@ -209,9 +209,10 @@ (apply #'%break 'break datum arguments))) ;;; These functions definitions are for cold-init. -;;; The real definitions are found in 'condition.lisp' -(defvar *!cold-warn-action* nil) +;;; The real definitions are found in 'warm-error.lisp' +(defvar *!cold-warn-action* #+sb-devel 'print #-sb-devel nil) (defun warn (datum &rest arguments) + (declare (explicit-check datum)) ;; CONDITION-CLASS not yet defined (when (and (stringp datum) (plusp (mismatch "defining setf macro" datum))) (return-from warn nil)) (let ((action (cond ((boundp '*!cold-warn-action*) *!cold-warn-action*) @@ -221,14 +222,30 @@ 'print)))) (when (member action '(lose print)) (let ((*package* *cl-package*)) - (write-string "cold WARN: datum=") ; WRITE could be too broken as yet + (write-string "cold WARN: datum=") (write (get-lisp-obj-address datum) :radix t :base 16) (write-string " = ") (write datum) (write-char #\space) (write (get-lisp-obj-address arguments) :radix t :base 16) - (terpri))) - (when (eq action 'lose) (sb-sys:%primitive sb-c:halt)))) + (terpri) + (cond ((typep datum 'instance) + (dotimes (i (%instance-length datum)) + (write-string " Slot ") + (write i) + (write-string " = ") + (write (%instance-ref datum i)) + (terpri))) + (arguments + (write-string "Args:") + (terpri) + (do-rest-arg ((arg) arguments) + (write-string " | ") + (write arg) + (terpri)))))) + (when (eq action 'lose) + (sb-sys:%primitive sb-c:halt) + (sb-impl::critically-unreachable "losing-warn")))) (defun style-warn (datum &rest arguments) (declare (notinline warn)) (apply 'warn datum arguments)) diff -Nru sbcl-2.1.1/src/code/cold-init-helper-macros.lisp sbcl-2.1.11/src/code/cold-init-helper-macros.lisp --- sbcl-2.1.1/src/code/cold-init-helper-macros.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cold-init-helper-macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -52,17 +52,6 @@ (makunbound '*!cold-init-forms*))) #-sb-xc (declare (ignore name))) -;;; !DEFINE-LOAD-TIME-GLOBAL avoids this anti-pattern: -;;; (!begin-collecting-cold-init-forms) -;;; (define-load-time-global *foo* nil) -;;; (!cold-init-forms (setq *foo* nil)) -;;; (!defun-from-cold-init-forms !some-cold-init-fun) -(defmacro !define-load-time-global (sym value &optional (doc nil doc-p)) - `(progn (define-load-time-global ,sym ,value ,@(if doc-p (list doc))) - ;; The expansion of the DEFINE-L-T-G is too hairy to fopcompile, - ;; but SETQ is ok provided that the value form is ok. - #-sb-xc-host (setq ,sym ,value))) - (defmacro !set-load-form-method (class-name usable-by &optional method) ;; If USABLE-BY is: ;; :host - the host compiler can execute this M-L-F method @@ -81,11 +70,11 @@ (values nil `(funcall ,method obj env)))) `(progn ,@(when (or #+sb-xc-host (member :host usable-by)) - `((defmethod make-load-form ((obj ,class-name) &optional env) + `((defmethod cl:make-load-form ((obj ,class-name) &optional env) ,host-expr))) ,@(when (or #+sb-xc-host (member :xc usable-by)) ;; Use the host's CLOS implementation to select the target's method. - `((defmethod sb-xc:make-load-form ((obj ,class-name) &optional env) + `((defmethod make-load-form ((obj ,class-name) &optional env) (declare (ignorable obj env)) ,target-expr))) ,@(when (or #-sb-xc-host (member :target usable-by)) diff -Nru sbcl-2.1.1/src/code/cold-init.lisp sbcl-2.1.11/src/code/cold-init.lisp --- sbcl-2.1.1/src/code/cold-init.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cold-init.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -40,10 +40,8 @@ ;;;; !COLD-INIT ;;; a list of toplevel things set by GENESIS -(defvar *!cold-toplevels*) ; except for DEFUNs and SETF macros -(defvar *!cold-setf-macros*) ; just SETF macros -(defvar *!cold-defuns*) ; just DEFUNs -(defvar *!cold-defsymbols*) ; "easy" DEFCONSTANTs and DEFPARAMETERs +(defvar *!cold-toplevels*) +(defvar *!cold-defsymbols*) ; "easy" DEFCONSTANTs ;;; a SIMPLE-VECTOR set by GENESIS (defvar *!load-time-values*) @@ -58,27 +56,74 @@ (defun !c-runtime-noinform-p () (/= (extern-alien "lisp_startup_options" char) 0)) +(defun !format-cold-init () + (sb-format::!late-format-init) + (sb-format::!format-directives-init)) + +;;; Allows the SIGNAL function to be called early. +(defun !signal-function-cold-init () + #+sb-devel + (progn + (setq *break-on-signals* nil) + (setq sb-kernel::*current-error-depth* 0)) + (setq *stack-top-hint* nil)) + +(defun !printer-control-init () + (setq *print-readably* nil + *print-escape* t + *print-pretty* nil + *print-base* 10 + *print-radix* nil + *print-vector-length* nil + *print-circle* nil + *print-case* :upcase + *print-array* t + *print-gensym* t + *print-lines* nil + *print-right-margin* nil + *print-miser-width* nil + *print-pprint-dispatch* (sb-pretty::make-pprint-dispatch-table #() nil nil) + *suppress-print-errors* nil + *current-level-in-print* 0)) + ;;; called when a cold system starts up (defun !cold-init (&aux (real-choose-symbol-out-fun #'choose-symbol-out-fun) (real-failed-aver-fun #'%failed-aver)) "Give the world a shove and hope it spins." (/show0 "entering !COLD-INIT") - (setf (symbol-function '%failed-aver) #'!cold-failed-aver) - (!readtable-cold-init) - (setq *readtable* (make-readtable) - *print-length* 6 *print-level* 3) - (setq *error-output* (!make-cold-stderr-stream) - *standard-output* *error-output* - *trace-output* *error-output*) + #+sb-show (setq */show* t) + (/show0 "cold-initializing streams") + (sb-impl::!cold-stream-init) + (show-and-call !signal-function-cold-init) + (show-and-call !printer-control-init) ; needed before first instance of FORMAT or WRITE-STRING + (setq *unparse-fun-type-simplify* nil) ; needed by TLFs in target-error.lisp + (setq sb-unix::*unblock-deferrables-on-enabling-interrupts-p* nil) ; needed by LOAD-LAYOUT called by CLASSES-INIT + (setq *print-length* 6 + *print-level* 3) (/show "testing '/SHOW" *print-length* *print-level*) ; show anything + ;; This allows FORMAT to work, and can go as early needed for + ;; debugging. + (show-and-call !format-cold-init) (unless (!c-runtime-noinform-p) ;; I'd like FORMAT to remain working in cold-init, where it does work, ;; hence the conditional. #+(or x86 x86-64) (format t "COLD-INIT... ") #-(or x86 x86-64) (write-string "COLD-INIT... ")) - (!cold-init-hash-table-methods) - ;; And now *CURRENT-THREAD* and *HANDLER-CLUSTERS* + + ;; Anyone might call RANDOM to initialize a hash value or something; + ;; and there's nothing which needs to be initialized in order for + ;; this to be initialized, so we initialize it right away. + (show-and-call !random-cold-init) + + ;; All sorts of things need INFO and/or (SETF INFO). + (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT") + (show-and-call !globaldb-cold-init) + (show-and-call !function-names-init) + + (setf (symbol-function '%failed-aver) #'!cold-failed-aver) + + ;; And now *CURRENT-THREAD* (sb-thread::init-main-thread) ;; Assert that FBOUNDP doesn't choke when its answer is NIL. @@ -86,21 +131,17 @@ ;; And be extra paranoid - ensure that it really gets called. (locally (declare (notinline fboundp)) (fboundp '(setf !zzzzzz))) - ;; Anyone might call RANDOM to initialize a hash value or something; - ;; and there's nothing which needs to be initialized in order for - ;; this to be initialized, so we initialize it right away. - (show-and-call !random-cold-init) - - ;; Putting data in a synchronized hashtable (*PACKAGE-NAMES*) - ;; requires that the main thread be properly initialized. - (show-and-call thread-init-or-reinit) ;; Printing of symbols requires that packages be filled in, because - ;; OUTPUT-SYMBOL calls FIND-SYMBOL to determine accessibility. + ;; OUTPUT-SYMBOL calls FIND-SYMBOL to determine accessibility. Also + ;; allows IN-PACKAGE to work. (show-and-call !package-cold-init) - (setq *print-pprint-dispatch* (sb-pretty::make-pprint-dispatch-table nil nil nil)) - ;; Because L-T-V forms have not executed, CHOOSE-SYMBOL-OUT-FUN doesn't work. - (setf (symbol-function 'choose-symbol-out-fun) - (lambda (&rest args) (declare (ignore args)) #'output-preserve-symbol)) + ;; debug machinery needed for printing symbols + #+sb-devel + (progn + (!readtable-cold-init) + ;; Because L-T-V forms have not executed, CHOOSE-SYMBOL-OUT-FUN doesn't work. + (setf (symbol-function 'choose-symbol-out-fun) + (lambda (&rest args) (declare (ignore args)) #'output-preserve-symbol))) ;; *RAW-SLOT-DATA* is essentially a compile-time constant ;; but isn't dumpable as such because it has functions in it. @@ -109,24 +150,14 @@ ;; Must be done before any non-opencoded array references are made. (show-and-call sb-vm::!hairy-data-vector-reffer-init) - (show-and-call !character-database-cold-init) - (show-and-call !character-name-database-cold-init) - (show-and-call sb-unicode::!unicode-properties-cold-init) - - ;; All sorts of things need INFO and/or (SETF INFO). - (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT") - (show-and-call !globaldb-cold-init) - ;; Various toplevel forms call MAKE-ARRAY, which calls SUBTYPEP, so ;; the basic type machinery needs to be initialized before toplevel ;; forms run. (show-and-call !type-class-cold-init) - (show-and-call sb-kernel::!primordial-type-cold-init) (show-and-call !classes-cold-init) - (show-and-call !pred-cold-init) - (show-and-call !early-type-cold-init) - (show-and-call !late-type-cold-init) - (show-and-call !alien-type-cold-init) + (show-and-call sb-kernel::!primordial-type-cold-init) + + (show-and-call !type-cold-init) ;; FIXME: It would be tidy to make sure that that these cold init ;; functions are called in the same relative order as the toplevel ;; forms of the corresponding source files. @@ -139,31 +170,24 @@ ;; to the subclasses of STRUCTURE-OBJECT. (show-and-call sb-kernel::!set-up-structure-object-class) - ;; Genesis is able to perform some of the work of DEFCONSTANT and - ;; DEFPARAMETER, but not all of it. It assigns symbol values, but can not - ;; manipulate globaldb. Therefore, a subtlety of these macros for bootstrap - ;; is that we see each DEFthing twice: once during cold-load and again here. - ;; Now it being the case that DEFPARAMETER implies variable assignment - ;; unconditionally, you may think it should assign. No! This was logically - ;; ONE use of the defining macro, but split into pieces as a consequence - ;; of the implementation. + ;; Genesis is able to perform some of the work of DEFCONSTANT, but + ;; not all of it. It assigns symbol values, but can not manipulate + ;; globaldb. Therefore, a subtlety of these macros for bootstrap is + ;; that we see each DEFthing twice: once during cold-load and again + ;; here. + (setq sb-pcl::*!docstrings* nil) ; needed by %DEFCONSTANT (dolist (x *!cold-defsymbols*) (destructuring-bind (fun name source-loc . docstring) x (aver (boundp name)) ; it's a bug if genesis didn't initialize (ecase fun - (sb-c::%defconstant - (apply #'sb-c::%defconstant name (symbol-value name) source-loc docstring)) - (sb-impl::%defparameter ; use %DEFVAR which will not clobber - (apply #'%defvar name source-loc nil docstring))))) - (dolist (x *!cold-defuns*) - (destructuring-bind (name inline-expansion dxable-args) x - (%defun name (fdefinition name) inline-expansion dxable-args))) + (%defconstant + (apply #'%defconstant name (symbol-value name) source-loc docstring))))) (unless (!c-runtime-noinform-p) - #+(or x86 x86-64) (format t "[Length(TLFs)=~D]~%" (length *!cold-toplevels*)) - #-(or x86 x86-64) - (progn (write `("Length(TLFs)=" ,(length *!cold-toplevels*)) :escape nil) - (terpri))) + #+(or x86 x86-64) (format t "[Length(TLFs)=~D]" (length *!cold-toplevels*)) + #-(or x86 x86-64) (write `("Length(TLFs)=" ,(length *!cold-toplevels*)) :escape nil)) + + (setq sb-c::*queued-proclaims* nil) ; needed before any proclaims are run (loop with *package* = *package* ; rebind to self, as if by LOAD for index-in-cold-toplevels from 0 @@ -184,16 +208,17 @@ (aver (typep object 'code-component)) (aver (unbound-marker-p (code-header-ref object index))) (setf (code-header-ref object index) (svref *!load-time-values* value)))) - ((cons (eql defstruct)) - (apply 'sb-kernel::%defstruct (cdr toplevel-thing))) + ((cons (eql :begin-file)) + (unless (!c-runtime-noinform-p) (print (cdr toplevel-thing)))) (t (!cold-lose "bogus operation in *!COLD-TOPLEVELS*")))) (/show0 "done with loop over cold toplevel forms and fixups") + (unless (!c-runtime-noinform-p) (terpri)) ;; Precise GC seems to think these symbols are live during the final GC ;; which in turn enlivens a bunch of other "*!foo*" symbols. ;; Setting them to NIL helps a little bit. - (setq *!cold-defuns* nil *!cold-defsymbols* nil *!cold-toplevels* nil) + (setq *!cold-defsymbols* nil *!cold-toplevels* nil) ;; Now that L-T-V forms have executed, the symbol output chooser works. (setf (symbol-function 'choose-symbol-out-fun) real-choose-symbol-out-fun) @@ -329,10 +354,6 @@ ;;;; initialization functions -(defun thread-init-or-reinit () - (sb-thread::init-job-control) - (sb-thread::get-foreground)) - (defun reinit (total) ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS. (without-gcing @@ -345,7 +366,6 @@ ;; Initialize streams next, so that any errors can be printed (stream-reinit t) (os-cold-init-or-reinit) - (thread-init-or-reinit) #-(and win32 (not sb-thread)) (signal-cold-init-or-reinit) (setf (extern-alien "internal_errors_enabled" int) 1) @@ -357,8 +377,8 @@ ;; re-disable ldb again. (when (eq *invoke-debugger-hook* 'sb-debug::debugger-disabled-hook) (sb-debug::disable-debugger)) - #+sb-thread (finalizer-thread-start) - (call-hooks "initialization" *init-hooks*)) + (call-hooks "initialization" *init-hooks*) + #+sb-thread (finalizer-thread-start)) ;;;; some support for any hapless wretches who end up debugging cold ;;;; init code diff -Nru sbcl-2.1.1/src/code/common-os.lisp sbcl-2.1.11/src/code/common-os.lisp --- sbcl-2.1.1/src/code/common-os.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/common-os.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -35,7 +35,7 @@ (define-load-time-global *core-string* "") (define-load-time-global *core-pathname* nil "The absolute pathname of the running SBCL core.") - +(define-load-time-global *software-version* nil) (define-load-time-global *runtime-pathname* nil "The absolute pathname of the running SBCL runtime.") (define-load-time-global *sbcl-homedir-pathname* nil) diff -Nru sbcl-2.1.1/src/code/condition-boot.lisp sbcl-2.1.11/src/code/condition-boot.lisp --- sbcl-2.1.1/src/code/condition-boot.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/condition-boot.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-KERNEL") - -(!defstruct-with-alternate-metaclass condition - :slot-names (assigned-slots) - :constructor nil - :superclass-name t - :metaclass-name condition-classoid - :metaclass-constructor make-condition-classoid - :dd-type structure) - -;;; Define just enough condition-classoids to get TYPEP -;;; to optimize into classoid-typep. -(macrolet ((def (name direct-supers &rest inherits) - `(eval-when (:compile-toplevel :execute) - ;; INHERITS is a list of symbols, unevaluated, - ;; excluding T which is assumed. - (%compiler-define-condition - ',name ',direct-supers - ,(make-layout - (hash-layout-name name) - (make-undefined-classoid name) - :flags +condition-layout-flag+ - :inherits (map 'vector #'find-layout (cons t inherits)) - :depthoid -1 - ;; 1 declared slot, plus the layout if it takes a slot - :length (+ sb-vm:instance-data-start 1)) - nil nil)))) - ;; These are grotesquely OAOO-violating, but on the bright side, - ;; compilation will fail if the subsequent real definition differs, - ;; so there's a built-in safety net. - ;; As has been suggested in 'cross-condition', a DEF!CONDITION macro - ;; might help, but still that's possibly not a complete solution, - ;; because DEBUG-CONDITION is defined in a file with the :NOT-HOST flag. - (def simple-condition (condition) condition) - (def warning (condition) condition) - (def style-warning (warning) condition warning) - (def compiler-note (condition) condition) - (def parse-unknown-type (condition) condition) - (def parse-deprecated-type (condition) condition) - (def serious-condition (condition) condition) - (def error (serious-condition) condition serious-condition) - (def sb-di:debug-condition (serious-condition) condition serious-condition) - (def stream-error (error) condition serious-condition error) - (def reference-condition (condition) condition) - ) - -;;; Needed for !CALL-A-METHOD to pick out CONDITIONs -(defun !condition-p (x) (typep x 'condition)) diff -Nru sbcl-2.1.1/src/code/condition.lisp sbcl-2.1.11/src/code/condition.lisp --- sbcl-2.1.1/src/code/condition.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/condition.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,2110 +0,0 @@ -;;;; stuff originally from CMU CL's error.lisp which can or should -;;;; come late (mostly related to the CONDITION class itself) -;;;; - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-KERNEL") - -;;;; the CONDITION class - -(/show0 "condition.lisp 20") - -(defstruct (condition-slot (:copier nil)) - (name (missing-arg) :type symbol) - ;; list of all applicable initargs - (initargs (missing-arg) :type list) - ;; names of reader and writer functions - (readers (missing-arg) :type list) - (writers (missing-arg) :type list) - ;; true if :INITFORM was specified - (initform-p (missing-arg) :type (member t nil)) - ;; the initform if :INITFORM was specified, otherwise NIL - (initform nil :type t) - ;; if this is a function, call it with no args to get the initform value - (initfunction (missing-arg) :type t) - ;; allocation of this slot, or NIL until defaulted - (allocation nil :type (member :instance :class nil)) - ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value - (cell nil :type (or cons null)) - ;; slot documentation - (documentation nil :type (or string null))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (/show0 "condition.lisp 103") - (let ((condition-class (find-classoid 'condition))) - (setf (condition-classoid-cpl condition-class) - (list condition-class))) - (/show0 "condition.lisp 103")) - -(setf (condition-classoid-report (find-classoid 'condition)) - (lambda (cond stream) - (format stream "Condition ~/sb-impl:print-type-specifier/ was signalled." - (type-of cond)))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defun find-condition-layout (name parent-types) - (let* ((cpl (remove-duplicates - (reverse - (reduce #'append - (mapcar (lambda (x) - (condition-classoid-cpl - (find-classoid x))) - parent-types))))) - (cond-layout (info :type :compiler-layout 'condition)) - (olayout (info :type :compiler-layout name)) - ;; FIXME: Does this do the right thing in case of multiple - ;; inheritance? A quick look at DEFINE-CONDITION didn't make - ;; it obvious what ANSI intends to be done in the case of - ;; multiple inheritance, so it's not actually clear what the - ;; right thing is.. - (new-inherits - (order-layout-inherits (concatenate 'simple-vector - (layout-inherits cond-layout) - (mapcar #'classoid-layout cpl))))) - (if (and olayout - (not (mismatch (layout-inherits olayout) new-inherits))) - olayout - ;; All condition classoid layouts carry the same LAYOUT-INFO - the defstruct - ;; description for CONDITION - which is a representation of the primitive object - ;; and not the lisp-level object. - (make-layout (hash-layout-name name) - (make-undefined-classoid name) - :info (layout-info cond-layout) - :flags +condition-layout-flag+ - :inherits new-inherits - :depthoid -1 - :length (layout-length cond-layout))))) - -) ; EVAL-WHEN - -;;; FIXME: ANSI's definition of DEFINE-CONDITION says -;;; Condition reporting is mediated through the PRINT-OBJECT method -;;; for the condition type in question, with *PRINT-ESCAPE* always -;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of -;;; a condition type C is equivalent to: -;;; (defmethod print-object ((x c) stream) -;;; (if *print-escape* (call-next-method) (report-name x stream))) -;;; The current code doesn't seem to quite match that. -(defmethod print-object ((object condition) stream) - (cond - ((not *print-escape*) - ;; KLUDGE: A comment from CMU CL here said - ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of - ;; superclasses in define-condition call! - (funcall (or (some #'condition-classoid-report - (condition-classoid-cpl (classoid-of object))) - (error "no REPORT? shouldn't happen!")) - object stream)) - ((and (typep object 'simple-condition) - (condition-slot-value object 'format-control)) - (print-unreadable-object (object stream :type t :identity t) - (write (simple-condition-format-control object) - :stream stream :lines 1))) - (t - (print-unreadable-object (object stream :type t :identity t))))) - -;;;; slots of CONDITION objects - -(defun find-slot-default (class slot) - (multiple-value-bind (value found) (find-slot-default-initarg class slot) - ;; When CLASS or a superclass has a default initarg for SLOT, use - ;; that. - (cond (found - value) - ;; Otherwise use the initform of SLOT, if there is one. - ((condition-slot-initform-p slot) - (let ((initfun (condition-slot-initfunction slot))) - (aver (functionp initfun)) - (funcall initfun))) - (t - (error "Unbound condition slot: ~S" (condition-slot-name slot)))))) - -(defun find-slot-default-initarg (class slot) - (let ((initargs (condition-slot-initargs slot)) - (cpl (condition-classoid-cpl class))) - (dolist (class cpl) - (let ((direct-default-initargs - (condition-classoid-direct-default-initargs class))) - (dolist (initarg initargs) - (let ((initfunction (third (assoc initarg direct-default-initargs)))) - (when initfunction - (return-from find-slot-default-initarg - (values (funcall initfunction) t))))))) - (values nil nil))) - -(defun find-condition-class-slot (condition-class slot-name) - (dolist (sclass - (condition-classoid-cpl condition-class) - (error "There is no slot named ~S in ~S." - slot-name condition-class)) - (dolist (slot (condition-classoid-slots sclass)) - (when (eq (condition-slot-name slot) slot-name) - (return-from find-condition-class-slot slot))))) - -(defun set-condition-slot-value (condition new-value name) - (dolist (cslot (condition-classoid-class-slots - (layout-classoid (%instance-layout condition))) - (setf (getf (condition-assigned-slots condition) name) - new-value)) - (when (eq (condition-slot-name cslot) name) - (return (setf (car (condition-slot-cell cslot)) new-value))))) - -(defun condition-slot-value (condition name) - (let ((val (getf (condition-assigned-slots condition) name sb-pcl:+slot-unbound+))) - (if (unbound-marker-p val) - (let ((class (layout-classoid (%instance-layout condition)))) - (dolist (cslot - (condition-classoid-class-slots class) - (let ((instance-length (%instance-length condition)) - (slot (or (find-condition-class-slot class name) - (error "missing slot ~S of ~S" name condition)))) - (setf (getf (condition-assigned-slots condition) name) - (do ((i (+ sb-vm:instance-data-start 1) (+ i 2))) - ((>= i instance-length) (find-slot-default class slot)) - (when (member (%instance-ref condition i) - (condition-slot-initargs slot)) - (return (%instance-ref condition (1+ i)))))))) - (when (eq (condition-slot-name cslot) name) - (let ((value (car (condition-slot-cell cslot)))) - (if (unbound-marker-p value) - (error "Unbound condition slot: ~S" (condition-slot-name cslot)) - (return value)))))) - val))) - -;;;; MAKE-CONDITION - -;;; Pre-scan INITARGS to see whether any are stack-allocated. -;;; If not, then life is easy. If any are, then depending on whether the -;;; condition is a TYPE-ERROR, call TYPE-OF on the bad datum, so that -;;; if the condition outlives the extent of the object, and someone tries -;;; to print the condition, we don't crash. -;;; Putting a placeholder in for the datum would work, but seems a bit evil, -;;; since the user might actually want to know what it was. And we shouldn't -;;; assume that the object would definitely escape its dynamic-extent. - -(defun allocate-condition (designator &rest initargs) - (when (oddp (length initargs)) - (error 'simple-error - :format-control "odd-length initializer list: ~S." - ;; Passing the initargs to LIST avoids consing them into - ;; a list except when this error is signaled. - :format-arguments (list (apply #'list initargs)))) - ;; I am going to assume that people are not somehow getting to here - ;; with a CLASSOID, which is not strictly legal as a designator, - ;; but which is accepted because it is actually the desired thing. - ;; It doesn't seem worth sweating over that detail, and in any event - ;; we could say that it's a supported extension. - (let ((classoid (named-let lookup ((designator designator)) - (typecase designator - (symbol (find-classoid designator nil)) - (class (lookup (class-name designator))) - (t designator))))) - (unless (condition-classoid-p classoid) - (error 'simple-type-error - :datum designator - :expected-type 'sb-pcl::condition-class - :format-control "~S does not designate a condition class." - :format-arguments (list designator))) - (flet ((stream-err-p (layout) - (let ((stream-err-layout (load-time-value (find-layout 'stream-error)))) - (or (eq layout stream-err-layout) - (find stream-err-layout (layout-inherits layout))))) - (type-err-p (layout) - (let ((type-err-layout (load-time-value (find-layout 'type-error)))) - (or (eq layout type-err-layout) - (find type-err-layout (layout-inherits layout))))) - ;; avoid full calls to STACK-ALLOCATED-P here - (stackp (x) - (let ((addr (get-lisp-obj-address x))) - (and (sb-vm:is-lisp-pointer addr) - (<= (get-lisp-obj-address sb-vm:*control-stack-start*) addr) - (< addr (get-lisp-obj-address sb-vm:*control-stack-end*)))))) - (let* ((any-dx - (loop for arg-index from 1 below (length initargs) by 2 - thereis (stackp (fast-&rest-nth arg-index initargs)))) - (layout (classoid-layout classoid)) - (extra (if (and any-dx (type-err-p layout)) 2 0)) ; space for secret initarg - (instance (%make-instance (+ sb-vm:instance-data-start - 1 ; ASSIGNED-SLOTS - (length initargs) - extra))) - (data-index (1+ sb-vm:instance-data-start)) - (arg-index 0) - (have-type-error-datum) - (type-error-datum)) - (setf (%instance-layout instance) layout - (condition-assigned-slots instance) nil) - (macrolet ((store-pair (key val) - `(setf (%instance-ref instance data-index) ,key - (%instance-ref instance (1+ data-index)) ,val))) - (cond ((not any-dx) - ;; uncomplicated way - (loop (when (>= arg-index (length initargs)) (return)) - (store-pair (fast-&rest-nth arg-index initargs) - (fast-&rest-nth (1+ arg-index) initargs)) - (incf data-index 2) - (incf arg-index 2))) - (t - (loop (when (>= arg-index (length initargs)) (return)) - (let ((key (fast-&rest-nth arg-index initargs)) - (val (fast-&rest-nth (1+ arg-index) initargs))) - (when (and (eq key :datum) - (not have-type-error-datum) - (type-err-p layout)) - (setq type-error-datum val - have-type-error-datum t)) - (if (and (eq key :stream) (stream-err-p layout) (stackp val)) - (store-pair key (sb-impl::make-stub-stream val)) - (store-pair key val))) - (incf data-index 2) - (incf arg-index 2)) - (when (and have-type-error-datum (/= extra 0)) - ;; We can get into serious trouble here if the - ;; datum is already stack garbage! - (let ((actual-type (type-of type-error-datum))) - (store-pair 'dx-object-type actual-type)))))) - (values instance classoid))))) - -;;; Access the type of type-error-datum if the datum can't be accessed. -;;; Testing the stack pointer when rendering the condition is a heuristic -;;; that might work, but more likely, the erring frame has been exited -;;; and then the stack pointer changed again to make it seems like the -;;; object pointer is valid. I'm not sure what to do, but we can leave -;;; that decision for later. -(defun type-error-datum-stored-type (condition) - (do ((i (- (%instance-length condition) 2) (- i 2))) - ((<= i (1+ sb-vm:instance-data-start)) - (make-unbound-marker)) - (when (eq (%instance-ref condition i) 'dx-object-type) - (return (%instance-ref condition (1+ i)))))) - -(defun make-condition (type &rest initargs) - "Make an instance of a condition object using the specified initargs." - ;; Note: While ANSI specifies no exceptional situations in this function, - ;; ALLOCATE-CONDITION will signal a type error if TYPE does not designate - ;; a condition class. This seems fair enough. - (declare (explicit-check)) - ;; FIXME: the compiler should have a way to make GETF operate on a &MORE arg - ;; so that the initargs are never listified. - (declare (dynamic-extent initargs)) - (multiple-value-bind (condition classoid) - (apply #'allocate-condition type initargs) - - ;; Set any class slots with initargs present in this call. - (dolist (cslot (condition-classoid-class-slots classoid)) - (loop for (key value) on initargs by #'cddr - when (memq key (condition-slot-initargs cslot)) - do (setf (car (condition-slot-cell cslot)) value) - (return) - finally - (multiple-value-bind (value found) - (find-slot-default-initarg classoid cslot) - (when found - (setf (car (condition-slot-cell cslot)) value))))) - - ;; Default any slots with non-constant defaults now. - (dolist (hslot (condition-classoid-hairy-slots classoid)) - (when (dolist (initarg (condition-slot-initargs hslot) t) - (unless (unbound-marker-p (getf initargs initarg sb-pcl:+slot-unbound+)) - (return nil))) - (setf (getf (condition-assigned-slots condition) - (condition-slot-name hslot)) - (find-slot-default classoid hslot)))) - - condition)) - - -;;;; DEFINE-CONDITION - -;;; Compute the effective slots of CLASS, copying inherited slots and -;;; destructively modifying direct slots. -;;; -;;; FIXME: It'd be nice to explain why it's OK to destructively modify -;;; direct slots. Presumably it follows from the semantics of -;;; inheritance and redefinition of conditions, but finding the cite -;;; and documenting it here would be good. (Or, if this is not in fact -;;; ANSI-compliant, fixing it would also be good.:-) -(defun compute-effective-slots (class) - (collect ((res (copy-list (condition-classoid-slots class)))) - (dolist (sclass (cdr (condition-classoid-cpl class))) - (dolist (sslot (condition-classoid-slots sclass)) - (let ((found (find (condition-slot-name sslot) (res) - :key #'condition-slot-name))) - (cond (found - (setf (condition-slot-initargs found) - (union (condition-slot-initargs found) - (condition-slot-initargs sslot))) - (unless (condition-slot-initform-p found) - (setf (condition-slot-initform-p found) - (condition-slot-initform-p sslot)) - (setf (condition-slot-initform found) - (condition-slot-initform sslot)) - (setf (condition-slot-initfunction found) - (condition-slot-initfunction sslot))) - (unless (condition-slot-allocation found) - (setf (condition-slot-allocation found) - (condition-slot-allocation sslot)))) - (t - (res (copy-structure sslot))))))) - (res))) - -;;; Early definitions of slot accessor creators. -;;; -;;; Slot accessors must be generic functions, but ANSI does not seem -;;; to specify any of them, and we cannot support it before end of -;;; warm init. So we use ordinary functions inside SBCL, and switch to -;;; GFs only at the end of building. -(declaim (notinline install-condition-slot-reader - install-condition-slot-writer)) -(defun install-condition-slot-reader (name condition slot-name) - (declare (ignore condition)) - (setf (fdefinition name) - (set-closure-name - (lambda (condition) (condition-slot-value condition slot-name)) - t - `(condition-slot-reader ,name)))) -(defun install-condition-slot-writer (name condition slot-name) - (declare (ignore condition)) - (setf (fdefinition name) - (set-closure-name - (lambda (new-value condition) - (set-condition-slot-value condition new-value slot-name)) - t - `(condition-slot-writer ,name)))) - -(!define-load-time-global *define-condition-hooks* nil) - -(defun %set-condition-report (name report) - (setf (condition-classoid-report (find-classoid name)) - report)) - -(defun %define-condition (name parent-types layout slots - direct-default-initargs all-readers all-writers - source-location &optional documentation) - (call-with-defining-class - 'condition name - (lambda () - (%%compiler-define-condition name parent-types layout all-readers all-writers) - (let ((classoid (find-classoid name))) - (when source-location - (setf (classoid-source-location classoid) source-location)) - (setf (condition-classoid-slots classoid) slots - (condition-classoid-direct-default-initargs classoid) direct-default-initargs - (documentation name 'type) documentation) - - (dolist (slot slots) - ;; Set up reader and writer functions. - (let ((slot-name (condition-slot-name slot))) - (dolist (reader (condition-slot-readers slot)) - (install-condition-slot-reader reader name slot-name)) - (dolist (writer (condition-slot-writers slot)) - (install-condition-slot-writer writer name slot-name)))) - - ;; Compute effective slots and set up the class and hairy slots - ;; (subsets of the effective slots.) - (setf (condition-classoid-class-slots classoid) '() - (condition-classoid-hairy-slots classoid) '()) - (let ((eslots (compute-effective-slots classoid)) - (e-def-initargs - (reduce #'append - (mapcar #'condition-classoid-direct-default-initargs - (condition-classoid-cpl classoid))))) - (dolist (slot eslots) - (ecase (condition-slot-allocation slot) - (:class - (unless (condition-slot-cell slot) - (setf (condition-slot-cell slot) - (list (if (condition-slot-initform-p slot) - (let ((initfun (condition-slot-initfunction slot))) - (aver (functionp initfun)) - (funcall initfun)) - sb-pcl:+slot-unbound+)))) - (push slot (condition-classoid-class-slots classoid))) - ((:instance nil) - (setf (condition-slot-allocation slot) :instance) - ;; FIXME: isn't this "always hairy"? - (when (or (functionp (condition-slot-initfunction slot)) - (dolist (initarg (condition-slot-initargs slot) nil) - (when (functionp (third (assoc initarg e-def-initargs))) - (return t)))) - (push slot (condition-classoid-hairy-slots classoid))))))) - (dolist (fun *define-condition-hooks*) - (funcall fun classoid))))) - name) - -(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) - &body options) - "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option* - Define NAME as a condition type. This new type inherits slots and its - report function from the specified PARENT-TYPEs. A slot spec is a list of: - (slot-name :reader :initarg {Option Value}* - - The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION - and :TYPE and the overall options :DEFAULT-INITARGS and - [type] :DOCUMENTATION are also allowed. - - The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either - a string or a two-argument lambda or function name. If a function, the - function is called with the condition and stream to report the condition. - If a string, the string is printed. - - Condition types are classes, but (as allowed by ANSI and not as described in - CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and - SLOT-VALUE may not be used on condition objects." - (check-designator name define-condition) - (let* ((parent-types (or parent-types '(condition))) - (layout (find-condition-layout name parent-types)) - (documentation nil) - (report nil) - (direct-default-initargs ())) - (collect ((slots) - (all-readers nil append) - (all-writers nil append)) - (dolist (spec slot-specs) - (with-current-source-form (spec) - (when (keywordp spec) - (warn "Keyword slot name indicates probable syntax error:~% ~S" - spec)) - (let* ((spec (if (consp spec) spec (list spec))) - (slot-name (first spec)) - (allocation :instance) - (initform-p nil) - documentation - initform) - (collect ((initargs) - (readers) - (writers)) - (do ((options (rest spec) (cddr options))) - ((null options)) - (unless (and (consp options) (consp (cdr options))) - (error "malformed condition slot spec:~% ~S." spec)) - (let ((arg (second options))) - (case (first options) - (:reader (readers arg)) - (:writer (writers arg)) - (:accessor - (readers arg) - (writers `(setf ,arg))) - (:initform - (when initform-p - (error "more than one :INITFORM in ~S" spec)) - (setq initform-p t) - (setq initform arg)) - (:initarg (initargs arg)) - (:allocation - (setq allocation arg)) - (:documentation - (when documentation - (error "more than one :DOCUMENTATION in ~S" spec)) - (unless (stringp arg) - (error "slot :DOCUMENTATION argument is not a string: ~S" - arg)) - (setq documentation arg)) - (:type - (check-slot-type-specifier - arg slot-name (cons 'define-condition name))) - (t - (error "unknown slot option:~% ~S" (first options)))))) - - (all-readers (readers)) - (all-writers (writers)) - (slots `(make-condition-slot - :name ',slot-name - :initargs ',(initargs) - :readers ',(readers) - :writers ',(writers) - :initform-p ',initform-p - :documentation ',documentation - :initform ,(when initform-p `',initform) - :initfunction ,(when initform-p - `#'(lambda () ,initform)) - :allocation ',allocation)))))) - - (dolist (option options) - (unless (consp option) - (error "bad option:~% ~S" option)) - (case (first option) - (:documentation (setq documentation (second option))) - (:report - (let ((arg (second option))) - (setq report - `#'(named-lambda (condition-report ,name) (condition stream) - (declare (type condition condition) - (type stream stream)) - ,@(if (stringp arg) - `((declare (ignore condition)) - (write-string ,arg stream)) - `((funcall #',arg condition stream))))))) - (:default-initargs - (doplist (initarg initform) (rest option) - (push ``(,',initarg ,',initform ,#'(lambda () ,initform)) - direct-default-initargs))) - (t - (error "unknown option: ~S" (first option))))) - - ;; Maybe kill docstring, but only under the cross-compiler. - #+(and (not sb-doc) sb-xc-host) (setq documentation nil) - `(progn - ,@(when *top-level-form-p* - ;; Avoid dumping uninitialized layouts, for sb-fasl::dump-layout - `((eval-when (:compile-toplevel) - (%compiler-define-condition ',name ',parent-types ,layout - ',(all-readers) ',(all-writers))))) - (%define-condition ',name - ',parent-types - ,(if *top-level-form-p* - layout - `(find-condition-layout ',name ',parent-types)) - (list ,@(slots)) - (list ,@direct-default-initargs) - ',(all-readers) - ',(all-writers) - (sb-c:source-location) - ,@(and documentation - `(,documentation))) - ;; This needs to be after %DEFINE-CONDITION in case :REPORT - ;; is a lambda referring to condition slot accessors: - ;; they're not proclaimed as functions before it has run if - ;; we're under EVAL or loaded as source. - (%set-condition-report ',name ,report) - ',name)))) - -;;;; various CONDITIONs specified by ANSI - -(define-condition serious-condition (condition) ()) - -(define-condition error (serious-condition) ()) - -(define-condition warning (condition) ()) -(define-condition style-warning (warning) ()) - -(defun simple-condition-printer (condition stream) - (let ((control (simple-condition-format-control condition))) - (if control - (apply #'format stream - control - (simple-condition-format-arguments condition)) - (error "No format-control for ~S" condition)))) - -(define-condition simple-condition () - ((format-control :reader simple-condition-format-control - :initarg :format-control - :initform nil - :type format-control) - (format-arguments :reader simple-condition-format-arguments - :initarg :format-arguments - :initform nil - :type list)) - (:report simple-condition-printer)) - -(define-condition simple-warning (simple-condition warning) ()) - -(define-condition simple-error (simple-condition error) ()) - -(define-condition storage-condition (serious-condition) ()) - -(defun decode-type-error-context (context type) - (typecase context - (cons - (case (car context) - (:struct - (format nil "when setting slot ~s of structure ~s" - (cddr context) (cadr context))) - (t context))) - ((eql :aref) - (let (*print-circle*) - (format nil "when setting an element of (ARRAY ~s)" - type))) - ((eql :ftype) - "from the function type declaration.") - ((and symbol - (not null)) - (format nil "when binding ~s" context)) - (t - context))) - -(define-condition type-error (error) - ((datum :reader type-error-datum :initarg :datum) - (expected-type :reader type-error-expected-type :initarg :expected-type) - (context :initform nil :reader type-error-context :initarg :context)) - (:report - (lambda (condition stream) - (let ((type (type-error-expected-type condition))) - (format stream "~@" - (type-error-datum condition) - type - (decode-type-error-context (type-error-context condition) - type)))))) - -;;; not specified by ANSI, but too useful not to have around. -(define-condition simple-style-warning (simple-condition style-warning) ()) -(define-condition simple-type-error (simple-condition type-error) ()) - -(define-condition program-error (error) ()) -(define-condition parse-error (error) ()) -(define-condition control-error (error) ()) -(define-condition stream-error (error) - ((stream :reader stream-error-stream :initarg :stream))) - -(define-condition end-of-file (stream-error) () - (:report - (lambda (condition stream) - (format stream - "end of file on ~S" - (stream-error-stream condition))))) - -(define-condition closed-stream-error (stream-error) () - (:report - (lambda (condition stream) - (format stream "~S is closed" (stream-error-stream condition))))) - -(define-condition closed-saved-stream-error (closed-stream-error) () - (:report - (lambda (condition stream) - (format stream "~S was closed by SB-EXT:SAVE-LISP-AND-DIE" (stream-error-stream condition))))) - -(define-condition file-error (error) - ((pathname :reader file-error-pathname :initarg :pathname)) - (:report - (lambda (condition stream) - (format stream "error on file ~S" (file-error-pathname condition))))) - -(define-condition package-error (error) - ((package :reader package-error-package :initarg :package))) - -(define-condition cell-error (error) - ((name :reader cell-error-name :initarg :name))) - -(define-condition values-list-argument-error (type-error) - () - (:report - (lambda (condition stream) - (format stream "~@" - 'values-list (type-error-datum condition))))) - -(define-condition unbound-variable (cell-error) - ((not-yet-loaded :initform nil :reader not-yet-loaded :initarg :not-yet-loaded)) - (:report - (lambda (condition stream) - (format stream - "~@" - (cell-error-name condition) - (case (not-yet-loaded condition) - (:local - "~:@_It is a local variable ~ - not available at compile-time.") - (t - "")))))) - -(define-condition retry-unbound-variable - (simple-condition unbound-variable) ()) - -(define-condition undefined-function (cell-error) - ((not-yet-loaded :initform nil :reader not-yet-loaded :initarg :not-yet-loaded)) - (:report - (lambda (condition stream) - (let ((name (cell-error-name condition))) - (format stream - (if (and (symbolp name) (macro-function name)) - (sb-format:tokens "~@<~/sb-ext:print-symbol-with-prefix/ is a macro, ~ - not a function.~@:>") - (sb-format:tokens "~@")) - name - (case (not-yet-loaded condition) - (:local - (sb-format:tokens "~:@_It is a local function ~ - not available at compile-time.")) - ((t) (sb-format:tokens "~:@_It is defined earlier in the ~ - file but is not available at compile-time.")) - (t - ""))))))) - -(define-condition retry-undefined-function - (simple-condition undefined-function) ()) - -(define-condition special-form-function (undefined-function) () - (:report - (lambda (condition stream) - (format stream - "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S." - (cell-error-name condition))))) - -(define-condition arithmetic-error (error) - ((operation :reader arithmetic-error-operation - :initarg :operation - :initform nil) - (operands :reader arithmetic-error-operands - :initarg :operands)) - (:report (lambda (condition stream) - (format stream - "arithmetic error ~S signalled" - (type-of condition)) - (when (arithmetic-error-operation condition) - (format stream - "~%Operation was (~S ~{~S~^ ~})." - (arithmetic-error-operation condition) - (arithmetic-error-operands condition)))))) - -(define-condition division-by-zero (arithmetic-error) ()) -(define-condition floating-point-overflow (arithmetic-error) ()) -(define-condition floating-point-underflow (arithmetic-error) ()) -(define-condition floating-point-inexact (arithmetic-error) ()) -(define-condition floating-point-invalid-operation (arithmetic-error) ()) - -(define-condition print-not-readable (error) - ((object :reader print-not-readable-object :initarg :object)) - (:report - (lambda (condition stream) - (let ((obj (print-not-readable-object condition)) - (*print-array* nil)) - (format stream "~S cannot be printed readably." obj))))) - -(define-condition reader-error (parse-error stream-error) () - (:report (lambda (condition stream) - (%report-reader-error condition stream)))) - -;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and -;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from -;;; within SBCL itself) -;;; -;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with -;;; the letter of the ANSI spec: this is not a condition signalled by -;;; SIGNAL when a format-control is supplied by the function's first -;;; argument. It seems to me (WHN) to be basically in the spirit of -;;; the spec, but if not, it'd be straightforward to do our own -;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with -;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in -;;; place of CL:SIMPLE-CONDITION here.) -(define-condition simple-reader-error (reader-error simple-condition) - () - (:report (lambda (condition stream) - (%report-reader-error condition stream :simple t)))) - -;;; base REPORTing of a READER-ERROR -;;; -;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL -;;; and FORMAT-ARGS slots. -(defun %report-reader-error (condition stream &key simple position) - (let ((error-stream (stream-error-stream condition))) - (pprint-logical-block (stream nil) - (if simple - (apply #'format stream - (simple-condition-format-control condition) - (simple-condition-format-arguments condition)) - (prin1 (class-name (class-of condition)) stream)) - (format stream "~2I~@[~:@_ ~:@_~:{~:(~A~): ~S~:^, ~:_~}~]~:@_ ~:@_Stream: ~S" - (stream-error-position-info error-stream position) - error-stream)))) - -;;;; special SBCL extension conditions - -;;; an error apparently caused by a bug in SBCL itself -;;; -;;; Note that we don't make any serious effort to use this condition -;;; for *all* errors in SBCL itself. E.g. type errors and array -;;; indexing errors can occur in functions called from SBCL code, and -;;; will just end up as ordinary TYPE-ERROR or invalid index error, -;;; because the signalling code has no good way to know that the -;;; underlying problem is a bug in SBCL. But in the fairly common case -;;; that the signalling code does know that it's found a bug in SBCL, -;;; this condition is appropriate, reusing boilerplate and helping -;;; users to recognize it as an SBCL bug. -(define-condition bug (simple-error) - () - (:report - (lambda (condition stream) - (format stream - "~@< ~? ~:@_~?~:>" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - "~@.~:@>" - '((fmakunbound 'compile)))))) - -(define-condition simple-storage-condition (storage-condition simple-condition) - ()) - -(define-condition sanitizer-error (simple-error) - ((value :reader sanitizer-error-value :initarg :value) - (address :reader sanitizer-error-address :initarg :address) - (size :reader sanitizer-error-size :initarg :size))) - -;;; a condition for use in stubs for operations which aren't supported -;;; on some platforms -;;; -;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like -;;; #-(or freebsd linux) -;;; (defun load-foreign (&rest rest) -;;; (error 'unsupported-operator :name 'load-foreign)) -;;; #+(or freebsd linux) -;;; (defun load-foreign ... actual definition ...) -;;; By signalling a standard condition in this case, we make it -;;; possible for test code to distinguish between (1) intentionally -;;; unimplemented and (2) unintentionally just screwed up somehow. -;;; (Before this condition was defined, test code tried to deal with -;;; this by checking for FBOUNDP, but that didn't work reliably. In -;;; sbcl-0.7.0, a package screwup left the definition of -;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on -;;; architectures where it was supposed to be supported, and the -;;; regression tests cheerfully passed because they assumed that -;;; unFBOUNDPness meant they were running on an system which didn't -;;; support the extension.) -(define-condition unsupported-operator (simple-error) ()) - -;;; (:ansi-cl :function remove) -;;; (:ansi-cl :section (a b c)) -;;; (:ansi-cl :glossary "similar") -;;; -;;; (:sbcl :node "...") -;;; (:sbcl :variable *ed-functions*) -;;; -;;; FIXME: this is not the right place for this. -(defun print-reference (reference stream) - (ecase (car reference) - (:amop - (format stream "AMOP") - (format stream ", ") - (destructuring-bind (type data) (cdr reference) - (ecase type - (:readers "Readers for ~:(~A~) Metaobjects" - (substitute #\ #\- (symbol-name data))) - (:initialization - (format stream "Initialization of ~:(~A~) Metaobjects" - (substitute #\ #\- (symbol-name data)))) - (:generic-function (format stream "Generic Function ~S" data)) - (:function (format stream "Function ~S" data)) - (:section (format stream "Section ~{~D~^.~}" data))))) - (:ansi-cl - (format stream "The ANSI Standard") - (format stream ", ") - (destructuring-bind (type data) (cdr reference) - (ecase type - (:function (format stream "Function ~S" data)) - (:special-operator (format stream "Special Operator ~S" data)) - (:macro (format stream "Macro ~S" data)) - (:section (format stream "Section ~{~D~^.~}" data)) - (:glossary (format stream "Glossary entry for ~S" data)) - (:type (format stream "Type ~S" data)) - (:system-class (format stream "System Class ~S" data)) - (:issue (format stream "writeup for Issue ~A" data))))) - (:sbcl - (format stream "The SBCL Manual") - (format stream ", ") - (destructuring-bind (type data) (cdr reference) - (ecase type - (:node (format stream "Node ~S" data)) - (:variable (format stream "Variable ~S" data)) - (:function (format stream "Function ~S" data))))) - ;; FIXME: other documents (e.g. CLIM, Franz documentation :-) - )) -(define-condition reference-condition () - ((references :initarg :references :reader reference-condition-references))) -(defvar *print-condition-references* t) - -(define-condition simple-reference-error (reference-condition simple-error) - ()) - -(define-condition simple-reference-warning (reference-condition simple-warning) - ()) - -(define-condition arguments-out-of-domain-error - (arithmetic-error reference-condition) - ()) - -;; per CLHS: "The consequences are unspecified if functions are ... -;; multiply defined in the same file." so we are within reason to do any -;; unspecified behavior at compile-time and/or time, but the compiler was -;; annoyingly mum about genuinely inadvertent duplicate macro definitions. -;; Redefinition is henceforth a style-warning, and for compatibility it does -;; not cause the ERRORP value from COMPILE-TIME to be T. -;; Nor do we cite section 3.2.2.3 as the governing prohibition. -(defun report-duplicate-definition (condition stream) - (format stream "~@" - (slot-value condition 'name))) - -(define-condition duplicate-definition (reference-condition warning) - ((name :initarg :name :reader duplicate-definition-name)) - (:report report-duplicate-definition) - (:default-initargs :references '((:ansi-cl :section (3 2 2 3))))) -;; To my thinking, DUPLICATE-DEFINITION should be the ancestor condition, -;; and not fatal. But changing the meaning of that concept would be a bad idea, -;; so instead there is a new condition for the softer variant, which does not -;; inherit from the former. -(define-condition same-file-redefinition-warning (style-warning) - ;; Slot readers aren't proper generic functions until CLOS is built, - ;; so this doesn't get a reader because you can't pick the same name, - ;; and it wouldn't do any good to pick a different name that nothing knows. - ((name :initarg :name)) - (:report report-duplicate-definition)) - -(define-condition constant-modified (reference-condition warning) - ((fun-name :initarg :fun-name :reader constant-modified-fun-name) - (values :initform nil :initarg :values :reader constant-modified-values)) - (:report (lambda (c s) - (format s "~@" - (constant-modified-fun-name c) - (constant-modified-values c)))) - (:default-initargs :references '((:ansi-cl :special-operator quote) - (:ansi-cl :section (3 2 2 3))))) - -(define-condition macro-arg-modified (constant-modified) - ((variable :initform nil :initarg :variable :reader macro-arg-modified-variable)) - (:report (lambda (c s) - (format s "~@" - (constant-modified-fun-name c) - (macro-arg-modified-variable c)))) - (:default-initargs :references nil)) - -(define-condition package-at-variance (reference-condition simple-warning) - () - (:default-initargs :references '((:ansi-cl :macro defpackage) - (:sbcl :variable *on-package-variance*)))) - -(define-condition package-at-variance-error (reference-condition simple-condition - package-error) - () - (:default-initargs :references '((:ansi-cl :macro defpackage)))) - -(define-condition defconstant-uneql (reference-condition error) - ((name :initarg :name :reader defconstant-uneql-name) - (old-value :initarg :old-value :reader defconstant-uneql-old-value) - (new-value :initarg :new-value :reader defconstant-uneql-new-value)) - (:report - (lambda (condition stream) - (format stream - "~@" - (defconstant-uneql-name condition) - (defconstant-uneql-old-value condition) - (defconstant-uneql-new-value condition)))) - (:default-initargs :references '((:ansi-cl :macro defconstant) - (:sbcl :node "Idiosyncrasies")))) - -(define-condition array-initial-element-mismatch - (reference-condition simple-warning) - () - (:default-initargs - :references '((:ansi-cl :function make-array) - (:ansi-cl :function upgraded-array-element-type)))) - -(define-condition initial-element-mismatch-style-warning - (array-initial-element-mismatch simple-style-warning) - ()) - -(define-condition type-warning (reference-condition simple-warning) - () - (:default-initargs :references '((:sbcl :node "Handling of Types")))) -(define-condition type-style-warning (reference-condition simple-style-warning) - () - (:default-initargs :references '((:sbcl :node "Handling of Types")))) -(define-condition slot-initform-type-style-warning (type-style-warning) ()) - -(define-condition local-argument-mismatch (reference-condition simple-warning) - () - (:default-initargs :references '((:ansi-cl :section (3 2 2 3))))) - -(define-condition format-args-mismatch (reference-condition) - () - (:default-initargs :references '((:ansi-cl :section (22 3 10 2))))) - -(define-condition format-too-few-args-warning - (format-args-mismatch simple-warning) - ()) -(define-condition format-too-many-args-warning - (format-args-mismatch simple-style-warning) - ()) - -(define-condition implicit-generic-function-warning (style-warning) - ((name :initarg :name :reader implicit-generic-function-name)) - (:report - (lambda (condition stream) - (format stream "~@" - (implicit-generic-function-name condition))))) - -(define-condition extension-failure (reference-condition simple-error) - ()) - -(define-condition structure-initarg-not-keyword - (reference-condition simple-style-warning) - () - (:default-initargs :references '((:ansi-cl :section (2 4 8 13))))) - -(define-condition package-lock-violation (package-error - reference-condition - simple-condition) - ((current-package :initform *package* - :reader package-lock-violation-in-package)) - (:report - (lambda (condition stream) - (let ((control (simple-condition-format-control condition)) - (error-package (package-name - (package-error-package condition))) - (current-package (package-name - (package-lock-violation-in-package condition)))) - (format stream "~@" - error-package - (when control - (list control (simple-condition-format-arguments condition))) - current-package)))) - ;; no :default-initargs -- reference-stuff provided by the - ;; signalling form in target-package.lisp - (:documentation - "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled -when a package-lock is violated.")) - -(define-condition package-locked-error (package-lock-violation) () - (:documentation - "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is -signalled when an operation on a package violates a package lock.")) - -(define-condition symbol-package-locked-error (package-lock-violation) - ((symbol :initarg :symbol :reader package-locked-error-symbol)) - (:documentation - "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is -signalled when an operation on a symbol violates a package lock. The -symbol that caused the violation is accessed by the function -SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) - -(define-condition undefined-alien-error (cell-error) () - (:report - (lambda (condition stream) - (if (slot-boundp condition 'name) - (format stream "Undefined alien: ~S" (cell-error-name condition)) - (format stream "Undefined alien symbol."))))) - -(define-condition undefined-alien-variable-error (undefined-alien-error) () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream "Attempt to access an undefined alien variable.")))) - -(define-condition undefined-alien-function-error (undefined-alien-error) () - (:report - (lambda (condition stream) - (if (and (slot-boundp condition 'name) - (cell-error-name condition)) - (format stream "The alien function ~s is undefined." - (cell-error-name condition)) - (format stream "Attempt to call an undefined alien function."))))) - -(define-condition unknown-keyword-argument (program-error) - ((name :reader unknown-keyword-argument-name :initarg :name)) - (:report - (lambda (condition stream) - (format stream "Unknown &KEY argument: ~S" - (unknown-keyword-argument-name condition))))) - - -;;;; various other (not specified by ANSI) CONDITIONs -;;;; -;;;; These might logically belong in other files; they're here, after -;;;; setup of CONDITION machinery, only because that makes it easier to -;;;; get cold init to work. - -;;; OAOOM warning: see cross-condition.lisp -(define-condition encapsulated-condition (condition) - ((condition :initarg :condition :reader encapsulated-condition))) - -;;; KLUDGE: a condition for floating point errors when we can't or -;;; won't figure out what type they are. (In FreeBSD and OpenBSD we -;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably -;;; know how but the old code was broken by the conversion to POSIX -;;; signal handling and hasn't been fixed as of sbcl-0.6.7.) -;;; -;;; FIXME: Perhaps this should also be a base class for all -;;; floating point exceptions? -(define-condition floating-point-exception (arithmetic-error) - ((flags :initarg :traps - :initform nil - :reader floating-point-exception-traps)) - (:report (lambda (condition stream) - (format stream - "An arithmetic error ~S was signalled.~%" - (type-of condition)) - (let ((traps (floating-point-exception-traps condition))) - (if traps - (format stream - "Trapping conditions are: ~%~{ ~S~^~}~%" - traps) - (write-line - "No traps are enabled? How can this be?" - stream)))))) - -(define-condition invalid-array-index-error (type-error) - ((array :initarg :array :reader invalid-array-index-error-array) - (axis :initarg :axis :reader invalid-array-index-error-axis)) - (:report - (lambda (condition stream) - (let ((array (invalid-array-index-error-array condition))) - (format stream "Invalid index ~W for ~@[axis ~W of ~]~S, ~ - should be a non-negative integer below ~W." - (type-error-datum condition) - (when (> (array-rank array) 1) - (invalid-array-index-error-axis condition)) - (type-of array) - ;; Extract the bound from (INTEGER 0 (BOUND)) - (caaddr (type-error-expected-type condition))))))) - -(define-condition invalid-array-error (reference-condition type-error) () - (:report - (lambda (condition stream) - (let ((*print-array* nil)) - (format stream - "~@" - (type-error-expected-type condition) - (array-displacement (type-error-datum condition)))))) - (:default-initargs - :references - (list '(:ansi-cl :function adjust-array)))) - -(define-condition index-too-large-error (type-error) - ((sequence :initarg :sequence)) - (:report - (lambda (condition stream) - (let ((sequence (slot-value condition 'sequence)) - (index (type-error-datum condition))) - (if (vectorp sequence) - (format stream "Invalid index ~W for ~S ~@[with fill-pointer ~a~], ~ - should be a non-negative integer below ~W." - index - (type-of sequence) - (and (array-has-fill-pointer-p sequence) - (fill-pointer sequence)) - (length sequence)) - (format stream - "The index ~S is too large for a ~a of length ~s." - index - (if (listp sequence) - "list" - "sequence") - (length sequence))))))) - -(define-condition bounding-indices-bad-error (reference-condition type-error) - ((object :reader bounding-indices-bad-object :initarg :object)) - (:report - (lambda (condition stream) - (let* ((datum (type-error-datum condition)) - (start (car datum)) - (end (cdr datum)) - (object (bounding-indices-bad-object condition))) - (etypecase object - (sequence - (format stream - "The bounding indices ~S and ~S are bad ~ - for a sequence of length ~S." - start end (length object))) - (array - ;; from WITH-ARRAY-DATA - (format stream - "The START and END parameters ~S and ~S are ~ - bad for an array of total size ~S." - start end (array-total-size object))))))) - (:default-initargs - :references - (list '(:ansi-cl :glossary "bounding index designator") - '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR")))) - -(define-condition nil-array-accessed-error (reference-condition type-error) - () - (:report (lambda (condition stream) - (declare (ignore condition)) - (format stream - "An attempt to access an array of element-type ~ - NIL was made. Congratulations!"))) - (:default-initargs - :references '((:ansi-cl :function upgraded-array-element-type) - (:ansi-cl :section (15 1 2 1)) - (:ansi-cl :section (15 1 2 2))))) - -(define-condition namestring-parse-error (parse-error) - ((complaint :reader namestring-parse-error-complaint :initarg :complaint) - (args :reader namestring-parse-error-args :initarg :args :initform nil) - (namestring :reader namestring-parse-error-namestring :initarg :namestring) - (offset :reader namestring-parse-error-offset :initarg :offset)) - (:report - (lambda (condition stream) - (format stream - "parse error in namestring: ~?~% ~A~% ~V@T^" - (namestring-parse-error-complaint condition) - (namestring-parse-error-args condition) - (namestring-parse-error-namestring condition) - (namestring-parse-error-offset condition))))) - -(define-condition pathname-unparse-error (file-error - simple-condition) - ((problem :reader pathname-unparse-error-problem :initarg :problem)) - (:report (lambda (condition stream) - (format stream "~@" - (file-error-pathname condition) - (pathname-unparse-error-problem condition) - (simple-condition-format-control condition) - (simple-condition-format-arguments condition)))) - (:default-initargs - :problem (missing-arg))) - -(define-condition no-namestring-error (pathname-unparse-error - reference-condition) - () - (:default-initargs - :problem "does not have a namestring" - :references '((:ansi-cl :section (19 1 2))))) -(defun no-namestring-error - (pathname &optional format-control &rest format-arguments) - (error 'no-namestring-error - :pathname pathname - :format-control format-control :format-arguments format-arguments)) - -(define-condition no-native-namestring-error (pathname-unparse-error) - () - (:default-initargs - :problem "does not have a native namestring")) -(defun no-native-namestring-error - (pathname &optional format-control &rest format-arguments) - (error 'no-native-namestring-error - :pathname pathname - :format-control format-control :format-arguments format-arguments)) - -(define-condition simple-package-error (simple-condition package-error) ()) - -(define-condition package-does-not-exist (simple-package-error) ()) - -(define-condition simple-reader-package-error (simple-reader-error package-error) ()) -(define-condition reader-package-does-not-exist (simple-reader-package-error package-does-not-exist) ()) - -(define-condition reader-eof-error (end-of-file) - ((context :reader reader-eof-error-context :initarg :context)) - (:report - (lambda (condition stream) - (format stream - "unexpected end of file on ~S ~A" - (stream-error-stream condition) - (reader-eof-error-context condition))))) - -(define-condition reader-impossible-number-error (simple-reader-error) - ((error :reader reader-impossible-number-error-error :initarg :error)) - (:report - (lambda (condition stream) - (let ((error-stream (stream-error-stream condition))) - (format stream - "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" - (sb-impl::file-position-or-nil-for-error error-stream) error-stream - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - (reader-impossible-number-error-error condition)))))) - -(define-condition standard-readtable-modified-error (reference-condition error) - ((operation :initarg :operation :reader standard-readtable-modified-operation)) - (:report (lambda (condition stream) - (format stream "~S would modify the standard readtable." - (standard-readtable-modified-operation condition)))) - (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) - (:ansi-cl :glossary "standard readtable")))) - -(define-condition standard-pprint-dispatch-table-modified-error - (reference-condition error) - ((operation :initarg :operation - :reader standard-pprint-dispatch-table-modified-operation)) - (:report (lambda (condition stream) - (format stream "~S would modify the standard pprint dispatch table." - (standard-pprint-dispatch-table-modified-operation - condition)))) - (:default-initargs - :references `((:ansi-cl :glossary "standard pprint dispatch table")))) - -(define-condition timeout (serious-condition) - ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) - (:report (lambda (condition stream) - (format stream "Timeout occurred~@[ after ~A second~:P~]." - (timeout-seconds condition)))) - (:documentation - "Signaled when an operation does not complete within an allotted time budget.")) - -(define-condition io-timeout (stream-error timeout) - ((direction :reader io-timeout-direction :initarg :direction)) - (:report - (lambda (condition stream) - (declare (type stream stream)) - (format stream - "I/O timeout while doing ~(~A~) on ~S." - (io-timeout-direction condition) - (stream-error-stream condition))))) - -(define-condition deadline-timeout (timeout) - () - (:report (lambda (condition stream) - (format stream "A deadline was reached after ~A second~:P." - (timeout-seconds condition)))) - (:documentation - "Signaled when an operation in the context of a deadline takes -longer than permitted by the deadline.")) - -(define-condition declaration-type-conflict-error (reference-condition - simple-error) - () - (:default-initargs - :format-control - #.(macroexpand-1 ; stuff in a literal # - '(sb-format:tokens "Symbol ~/sb-ext:print-symbol-with-prefix/ cannot ~ - be both the name of a type and the name of a declaration")) - :references '((:ansi-cl :section (3 8 21))))) - -;;; Single stepping conditions - -(define-condition step-condition () - ((form :initarg :form :reader step-condition-form)) - (:documentation "Common base class of single-stepping conditions. -STEP-CONDITION-FORM holds a string representation of the form being -stepped.")) - -(setf (documentation 'step-condition-form 'function) - "Form associated with the STEP-CONDITION.") - -(define-condition step-form-condition (step-condition) - ((args :initarg :args :reader step-condition-args)) - (:report - (lambda (condition stream) - (let ((*print-circle* t) - (*print-pretty* t) - (*print-readably* nil)) - (format stream - "Evaluating call:~%~< ~@;~A~:>~%~ - ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%" - (list (step-condition-form condition)) - (eq (step-condition-args condition) :unknown) - (step-condition-args condition))))) - (:documentation "Condition signalled by code compiled with -single-stepping information when about to execute a form. -STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the -pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH -holds the source-path to the original form within that file or NIL. -Associated with this condition are always the restarts STEP-INTO, -STEP-NEXT, and STEP-CONTINUE.")) - -(define-condition step-result-condition (step-condition) - ((result :initarg :result :reader step-condition-result))) - -(setf (documentation 'step-condition-result 'function) - "Return values associated with STEP-VALUES-CONDITION as a list, -or the variable value associated with STEP-VARIABLE-CONDITION.") - -(define-condition step-values-condition (step-result-condition) - () - (:documentation "Condition signalled by code compiled with -single-stepping information after executing a form. -STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds -the values returned by the form as a list. No associated restarts.")) - -(define-condition step-finished-condition (step-condition) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream "Returning from STEP"))) - (:documentation "Condition signaled when STEP returns.")) - -;;; A knob for muffling warnings, mostly for use while loading files. -(defvar *muffled-warnings* 'uninteresting-redefinition - "A type that ought to specify a subtype of WARNING. Whenever a -warning is signaled, if the warning is of this type and is not -handled by any other handler, it will be muffled.") - -;;; Various STYLE-WARNING signaled in the system. -;; For the moment, we're only getting into the details for function -;; redefinitions, but other redefinitions could be done later -;; (e.g. methods). -(define-condition redefinition-warning (style-warning) - ((name - :initarg :name - :reader redefinition-warning-name) - (new-location - :initarg :new-location - :reader redefinition-warning-new-location))) - -(define-condition function-redefinition-warning (redefinition-warning) - ((new-function - :initarg :new-function - :reader function-redefinition-warning-new-function))) - -(define-condition redefinition-with-defun (function-redefinition-warning) - () - (:report (lambda (warning stream) - (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~ - in DEFUN" - (redefinition-warning-name warning))))) - -(define-condition redefinition-with-defmacro (function-redefinition-warning) - () - (:report (lambda (warning stream) - (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~ - in DEFMACRO" - (redefinition-warning-name warning))))) - -(define-condition redefinition-with-defgeneric (redefinition-warning) - () - (:report (lambda (warning stream) - (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~ - in DEFGENERIC" - (redefinition-warning-name warning))))) - -(define-condition redefinition-with-defmethod (redefinition-warning) - ((qualifiers :initarg :qualifiers - :reader redefinition-with-defmethod-qualifiers) - (specializers :initarg :specializers - :reader redefinition-with-defmethod-specializers) - (new-location :initarg :new-location - :reader redefinition-with-defmethod-new-location) - (old-method :initarg :old-method - :reader redefinition-with-defmethod-old-method)) - (:report (lambda (warning stream) - (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD" - (redefinition-warning-name warning) - (redefinition-with-defmethod-qualifiers warning) - (redefinition-with-defmethod-specializers warning))))) - -;;;; Deciding which redefinitions are "interesting". - -(defun function-file-namestring (function) - (when (typep function 'interpreted-function) - (return-from function-file-namestring - #+sb-eval - (sb-c:definition-source-location-namestring - (sb-eval:interpreted-function-source-location function)) - #+sb-fasteval - (awhen (sb-interpreter:fun-source-location function) - (sb-c:definition-source-location-namestring it)))) - (let* ((fun (%fun-fun function)) - (code (fun-code-header fun)) - (debug-info (%code-debug-info code)) - (debug-source (when debug-info - (sb-c::debug-info-source debug-info))) - (namestring (when debug-source - (debug-source-namestring debug-source)))) - namestring)) - -(defun interesting-function-redefinition-warning-p (warning old) - (let ((new (function-redefinition-warning-new-function warning))) - (or - ;; compiled->interpreted is interesting. - (and (typep old 'compiled-function) - (typep new '(not compiled-function))) - ;; fin->regular is interesting except for interpreted->compiled. - (and (typep new '(not funcallable-instance)) - (typep old '(and funcallable-instance (not interpreted-function)))) - ;; different file or unknown location is interesting. - (let* ((old-namestring (function-file-namestring old)) - (new-namestring (function-file-namestring new))) - (and (or (not old-namestring) - (not new-namestring) - (not (string= old-namestring new-namestring)))))))) - -(setf (info :function :predicate-truth-constraint - 'uninteresting-ordinary-function-redefinition-p) 'warning) -(defun uninteresting-ordinary-function-redefinition-p (warning) - (and - (typep warning 'redefinition-with-defun) - ;; Shared logic. - (let ((name (redefinition-warning-name warning))) - (not (interesting-function-redefinition-warning-p - warning (or (fdefinition name) (macro-function name))))))) - -(setf (info :function :predicate-truth-constraint - 'uninteresting-macro-redefinition-p) 'warning) -(defun uninteresting-macro-redefinition-p (warning) - (and - (typep warning 'redefinition-with-defmacro) - ;; Shared logic. - (let ((name (redefinition-warning-name warning))) - (not (interesting-function-redefinition-warning-p - warning (or (macro-function name) (fdefinition name))))))) - -(setf (info :function :predicate-truth-constraint - 'uninteresting-generic-function-redefinition-p) 'warning) -(defun uninteresting-generic-function-redefinition-p (warning) - (and - (typep warning 'redefinition-with-defgeneric) - ;; Can't use the shared logic above, since GF's don't get a "new" - ;; definition -- rather the FIN-FUNCTION is set. - (let* ((name (redefinition-warning-name warning)) - (old (fdefinition name)) - (old-location (when (typep old 'generic-function) - (sb-pcl::definition-source old))) - (old-namestring (when old-location - (sb-c:definition-source-location-namestring old-location))) - (new-location (redefinition-warning-new-location warning)) - (new-namestring (when new-location - (sb-c:definition-source-location-namestring new-location)))) - (and old-namestring - new-namestring - (string= old-namestring new-namestring))))) - -(setf (info :function :predicate-truth-constraint - 'uninteresting-method-redefinition-p) 'warning) -(defun uninteresting-method-redefinition-p (warning) - (and - (typep warning 'redefinition-with-defmethod) - ;; Can't use the shared logic above, since GF's don't get a "new" - ;; definition -- rather the FIN-FUNCTION is set. - (let* ((old-method (redefinition-with-defmethod-old-method warning)) - (old-location (sb-pcl::definition-source old-method)) - (old-namestring (when old-location - (sb-c:definition-source-location-namestring old-location))) - (new-location (redefinition-warning-new-location warning)) - (new-namestring (when new-location - (sb-c:definition-source-location-namestring new-location)))) - (and new-namestring - old-namestring - (string= new-namestring old-namestring))))) - -(deftype uninteresting-redefinition () - '(or (satisfies uninteresting-ordinary-function-redefinition-p) - (satisfies uninteresting-macro-redefinition-p) - (satisfies uninteresting-generic-function-redefinition-p) - (satisfies uninteresting-method-redefinition-p))) - -(define-condition redefinition-with-deftransform (redefinition-warning) - ((transform :initarg :transform - :reader redefinition-with-deftransform-transform)) - (:report (lambda (warning stream) - (format stream "Overwriting ~S" - (redefinition-with-deftransform-transform warning))))) - -;;; Various other STYLE-WARNINGS -(define-condition dubious-asterisks-around-variable-name - (style-warning simple-condition) - () - (:report (lambda (warning stream) - (format stream "~@?, even though the name follows~@ -the usual naming convention (names like *FOO*) for special variables" - (simple-condition-format-control warning) - (simple-condition-format-arguments warning))))) - -(define-condition asterisks-around-lexical-variable-name - (dubious-asterisks-around-variable-name) - ()) - -(define-condition asterisks-around-constant-variable-name - (dubious-asterisks-around-variable-name) - ()) - -(define-condition &optional-and-&key-in-lambda-list - (style-warning simple-condition) - ()) - -;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some -;; subclasses of ERROR above having to do with undefined aliens. -(define-condition undefined-alien-style-warning (style-warning) - ((symbol :initarg :symbol :reader undefined-alien-symbol)) - (:report (lambda (warning stream) - (format stream "Undefined alien: ~S" - (undefined-alien-symbol warning))))) - -;;; Formerly this was guarded by "#+(or sb-eval sb-fasteval)", but -;;; why would someone build with no interpreter? And if they did, -;;; would they really care that one extra condition definition exists? -(define-condition lexical-environment-too-complex (style-warning) - ((form :initarg :form :reader lexical-environment-too-complex-form) - (lexenv :initarg :lexenv :reader lexical-environment-too-complex-lexenv)) - (:report (lambda (warning stream) - (format stream - "~@" - (lexical-environment-too-complex-form warning) - (lexical-environment-too-complex-lexenv warning))))) - -;; If the interpreter is in use (and the REPL is interpreted), -;; it's easy to accidentally make the macroexpand-hook an interpreted -;; function. So MACROEXPAND-1 is a little more careful, -;; and might signal this, instead of only EVAL being able to signal it. -(define-condition macroexpand-hook-type-error (type-error) - () - (:report (lambda (condition stream) - (format stream "The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~S" - (type-error-datum condition))))) - -;; Although this has -ERROR- in the name, it's just a STYLE-WARNING. -(define-condition character-decoding-error-in-comment (style-warning) - ((stream :initarg :stream :reader decoding-error-in-comment-stream) - (position :initarg :position :reader decoding-error-in-comment-position)) - (:report (lambda (warning stream) - (format stream - "Character decoding error in a ~A-comment at ~ - position ~A reading source stream ~A, ~ - resyncing." - (decoding-error-in-comment-macro warning) - (decoding-error-in-comment-position warning) - (decoding-error-in-comment-stream warning))))) - -(define-condition character-decoding-error-in-macro-char-comment - (character-decoding-error-in-comment) - ((char :initform #\; :initarg :char - :reader character-decoding-error-in-macro-char-comment-char))) - -(define-condition character-decoding-error-in-dispatch-macro-char-comment - (character-decoding-error-in-comment) - ;; ANSI doesn't give a way for a reader function invoked by a - ;; dispatch macro character to determine which dispatch character - ;; was used, so if a user wants to signal one of these from a custom - ;; comment reader, he'll have to supply the :DISP-CHAR himself. - ((disp-char :initform #\# :initarg :disp-char - :reader character-decoding-error-in-macro-char-comment-disp-char) - (sub-char :initarg :sub-char - :reader character-decoding-error-in-macro-char-comment-sub-char))) - -(defun decoding-error-in-comment-macro (warning) - (etypecase warning - (character-decoding-error-in-macro-char-comment - (character-decoding-error-in-macro-char-comment-char warning)) - (character-decoding-error-in-dispatch-macro-char-comment - (format - nil "~C~C" - (character-decoding-error-in-macro-char-comment-disp-char warning) - (character-decoding-error-in-macro-char-comment-sub-char warning))))) - -(define-condition deprecated-eval-when-situations (style-warning) - ((situations :initarg :situations - :reader deprecated-eval-when-situations-situations)) - (:report (lambda (warning stream) - (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}" - (deprecated-eval-when-situations-situations warning))))) - -(define-condition proclamation-mismatch (condition) - ((kind :initarg :kind :reader proclamation-mismatch-kind) - (description :initarg :description :reader proclamation-mismatch-description :initform nil) - (name :initarg :name :reader proclamation-mismatch-name) - (old :initarg :old :reader proclamation-mismatch-old) - (new :initarg :new :reader proclamation-mismatch-new)) - (:report - (lambda (condition stream) - (format stream - "~@" - (proclamation-mismatch-kind condition) - (proclamation-mismatch-description condition) - (proclamation-mismatch-name condition) - (proclamation-mismatch-new condition) - (proclamation-mismatch-old condition))))) - -(define-condition type-proclamation-mismatch (proclamation-mismatch) - () - (:default-initargs :kind 'type)) - -(define-condition type-proclamation-mismatch-warning (style-warning - type-proclamation-mismatch) - ()) - -(define-condition ftype-proclamation-mismatch (proclamation-mismatch) - () - (:default-initargs :kind 'ftype)) - -(define-condition ftype-proclamation-mismatch-warning (style-warning - ftype-proclamation-mismatch) - ()) - -(define-condition ftype-proclamation-mismatch-error (error - ftype-proclamation-mismatch) - () - (:default-initargs :kind 'ftype :description "known function")) - - -;;;; deprecation conditions - -(define-condition deprecation-condition (reference-condition) - ((namespace :initarg :namespace - :reader deprecation-condition-namespace) - (name :initarg :name - :reader deprecation-condition-name) - (replacements :initarg :replacements - :reader deprecation-condition-replacements) - (software :initarg :software - :reader deprecation-condition-software) - (version :initarg :version - :reader deprecation-condition-version) - (runtime-error :initarg :runtime-error - :reader deprecation-condition-runtime-error - :initform nil)) - (:default-initargs - :namespace (missing-arg) - :name (missing-arg) - :replacements (missing-arg) - :software (missing-arg) - :version (missing-arg) - :references '((:sbcl :node "Deprecation Conditions"))) - (:documentation - "Superclass for deprecation-related error and warning -conditions.")) - -(defmethod print-object ((condition deprecation-condition) stream) - (flet ((print-it (stream) - (print-deprecation-message - (deprecation-condition-namespace condition) - (deprecation-condition-name condition) - (deprecation-condition-software condition) - (deprecation-condition-version condition) - (deprecation-condition-replacements condition) - stream))) - (if *print-escape* - (print-unreadable-object (condition stream :type t) - (print-it stream)) - (print-it stream)))) - -(macrolet ((define-deprecation-warning - (name superclass check-runtime-error format-string - &optional documentation) - `(progn - (define-condition ,name (,superclass deprecation-condition) - () - ,@(when documentation - `((:documentation ,documentation)))) - - (defmethod print-object :after ((condition ,name) stream) - (when (and (not *print-escape*) - ,@(when check-runtime-error - `((deprecation-condition-runtime-error condition)))) - (format stream ,format-string - (deprecation-condition-software condition) - (deprecation-condition-name condition))))))) - - ;; These conditions must not occur in self-build! - (define-deprecation-warning early-deprecation-warning style-warning nil - "~%~@<~:@_In future~@[ ~A~] versions ~ - ~/sb-ext:print-symbol-with-prefix/ will signal a full warning ~ - at compile-time.~:@>" - "This warning is signaled when the use of a variable, -function, type, etc. in :EARLY deprecation is detected at -compile-time. The use will work at run-time with no warning or -error.") - - (define-deprecation-warning late-deprecation-warning warning t - "~%~@<~:@_In future~@[ ~A~] versions ~ - ~/sb-ext:print-symbol-with-prefix/ will signal a runtime ~ - error.~:@>" - "This warning is signaled when the use of a variable, -function, type, etc. in :LATE deprecation is detected at -compile-time. The use will work at run-time with no warning or -error.") - - (define-deprecation-warning final-deprecation-warning warning t - "~%~@<~:@_~*An error will be signaled at runtime for ~ - ~/sb-ext:print-symbol-with-prefix/.~:@>" - "This warning is signaled when the use of a variable, -function, type, etc. in :FINAL deprecation is detected at -compile-time. An error will be signaled at run-time.")) - -(define-condition deprecation-error (error deprecation-condition) - () - (:documentation - "This error is signaled at run-time when an attempt is made to use -a thing that is in :FINAL deprecation, i.e. call a function or access -a variable.")) - -;;;; restart definitions - -(define-condition abort-failure (control-error) () - (:report - "An ABORT restart was found that failed to transfer control dynamically.")) - -(defun abort (&optional condition) - "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if - none exists." - (invoke-restart (find-restart-or-control-error 'abort condition)) - ;; ABORT signals an error in case there was a restart named ABORT - ;; that did not transfer control dynamically. This could happen with - ;; RESTART-BIND. - (error 'abort-failure)) - -(defun muffle-warning (&optional condition) - "Transfer control to a restart named MUFFLE-WARNING, signalling a - CONTROL-ERROR if none exists." - (invoke-restart (find-restart-or-control-error 'muffle-warning condition))) - -(defun try-restart (name condition &rest arguments) - (let ((restart (find-restart name condition))) - (when restart - (apply #'invoke-restart restart arguments)))) - -(macrolet ((define-nil-returning-restart (name args doc) - `(defun ,name (,@args &optional condition) - ,doc - (try-restart ',name condition ,@args)))) - (define-nil-returning-restart continue () - "Transfer control to a restart named CONTINUE, or return NIL if none exists.") - (define-nil-returning-restart store-value (value) - "Transfer control and VALUE to a restart named STORE-VALUE, or -return NIL if none exists.") - (define-nil-returning-restart use-value (value) - "Transfer control and VALUE to a restart named USE-VALUE, or -return NIL if none exists.") - (define-nil-returning-restart print-unreadably () - "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or -return NIL if none exists.")) - -;;; single-stepping restarts - -(macrolet ((def (name doc) - `(defun ,name (condition) - ,doc - (invoke-restart (find-restart-or-control-error ',name condition))))) - (def step-continue - "Transfers control to the STEP-CONTINUE restart associated with -the condition, continuing execution without stepping. Signals a -CONTROL-ERROR if the restart does not exist.") - (def step-next - "Transfers control to the STEP-NEXT restart associated with the -condition, executing the current form without stepping and continuing -stepping with the next form. Signals CONTROL-ERROR if the restart does -not exist.") - (def step-into - "Transfers control to the STEP-INTO restart associated with the -condition, stepping into the current form. Signals a CONTROL-ERROR if -the restart does not exist.")) - -;;; Compiler macro magic - -(define-condition compiler-macro-keyword-problem () - ((argument :initarg :argument :reader compiler-macro-keyword-argument)) - (:report (lambda (condition stream) - (format stream "~@" - (compiler-macro-keyword-argument condition))))) - -;; After (or if) we deem this the optimal name for this condition, -;; it should be exported from SB-EXT so that people can muffle it. -(define-condition sb-c:inlining-dependency-failure (simple-style-warning) ()) - - -(define-condition layout-invalid (type-error) - () - (:report - (lambda (condition stream) - (format stream - "~@" - (classoid-proper-name (type-error-expected-type condition)) - (type-error-datum condition))))) - -(define-condition case-failure (type-error) - ((name :reader case-failure-name :initarg :name) - (possibilities :reader case-failure-possibilities :initarg :possibilities)) - (:report - (lambda (condition stream) - (let ((*print-escape* t)) - (format stream "~@<~S fell through ~S expression.~@[ ~ - ~:_Wanted one of (~/pprint-fill/).~]~:>" - (type-error-datum condition) - (case-failure-name condition) - (case-failure-possibilities condition)))))) - -(define-condition compiled-program-error (program-error) - ((message :initarg :message :reader program-error-message) - (source :initarg :source :reader program-error-source)) - (:report (lambda (condition stream) - (format stream "Execution of a form compiled with errors.~%~ - Form:~% ~A~%~ - Compile-time error:~% ~A" - (program-error-source condition) - (program-error-message condition))))) - -(define-condition simple-control-error (simple-condition control-error) ()) - -(define-condition simple-file-error (simple-condition file-error) - ((message :initarg :message :reader simple-file-error-message :initform nil)) - (:report - (lambda (condition stream) - (format stream "~@<~?~@[: ~2I~_~A~]~@:>" - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - (simple-file-error-message condition))))) - -(defun %file-error (pathname &optional datum &rest arguments) - (typecase datum - (format-control (error 'simple-file-error :pathname pathname - :format-control datum - :format-arguments arguments)) - (t (apply #'error datum :pathname pathname arguments)))) - -(define-condition file-exists (simple-file-error) () - (:report - (lambda (condition stream) - (format stream "~@" - (file-error-pathname condition) - (simple-file-error-message condition))))) - -(define-condition file-does-not-exist (simple-file-error) () - (:report - (lambda (condition stream) - (format stream "~@" - (file-error-pathname condition) - (simple-file-error-message condition))))) - -(define-condition delete-file-error (simple-file-error) () - (:report - (lambda (condition stream) - (format stream "~@" - (file-error-pathname condition) - (simple-file-error-message condition))))) - -(define-condition simple-stream-error (simple-condition stream-error) ()) -(define-condition simple-parse-error (simple-condition parse-error) ()) - -(define-condition broken-pipe (simple-stream-error) ()) - -(define-condition character-coding-error (error) - ((external-format :initarg :external-format :reader character-coding-error-external-format))) -(define-condition character-encoding-error (character-coding-error) - ((code :initarg :code :reader character-encoding-error-code))) -(define-condition character-decoding-error (character-coding-error) - ((octets :initarg :octets :reader character-decoding-error-octets))) -(define-condition stream-encoding-error (stream-error character-encoding-error) - () - (:report - (lambda (c s) - (let ((stream (stream-error-stream c)) - (code (character-encoding-error-code c))) - (format s "~@<~S stream encoding error on ~S: ~2I~_~ - the character with code ~D cannot be encoded.~@:>" - (character-coding-error-external-format c) - stream - code))))) -(define-condition stream-decoding-error (stream-error character-decoding-error) - () - (:report - (lambda (c s) - (let ((stream (stream-error-stream c)) - (octets (character-decoding-error-octets c))) - (format s "~@<~S stream decoding error on ~S: ~2I~_~ - the octet sequence ~S cannot be decoded.~@:>" - (character-coding-error-external-format c) - stream - octets))))) - -(define-condition c-string-encoding-error (character-encoding-error) - () - (:report - (lambda (c s) - (format s "~@<~S c-string encoding error: ~2I~_~ - the character with code ~D cannot be encoded.~@:>" - (character-coding-error-external-format c) - (character-encoding-error-code c))))) - -(define-condition c-string-decoding-error (character-decoding-error) - () - (:report - (lambda (c s) - (format s "~@<~S c-string decoding error: ~2I~_~ - the octet sequence ~S cannot be decoded.~@:>" - (character-coding-error-external-format c) - (character-decoding-error-octets c))))) - -(define-condition control-stack-exhausted (storage-condition) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream - ;; no pretty-printing, because that would use a lot of stack. - "Control stack exhausted (no more space for function call frames). -This is probably due to heavily nested or infinitely recursive function -calls, or a tail call that SBCL cannot or has not optimized away. - -PROCEED WITH CAUTION.")))) - -(define-condition binding-stack-exhausted (storage-condition) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream - ;; no pretty-printing, because that would use a lot of stack. - "Binding stack exhausted. - -PROCEED WITH CAUTION.")))) - -(define-condition alien-stack-exhausted (storage-condition) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (format stream - ;; no pretty-printing, because that would use a lot of stack. - "Alien stack exhausted. - -PROCEED WITH CAUTION.")))) - -(define-condition heap-exhausted-error (storage-condition) - () - (:report - (lambda (condition stream) - (declare (ignore condition)) - (declare (special *heap-exhausted-error-available-bytes* - *heap-exhausted-error-requested-bytes*)) - ;; See comments in interr.lisp -- there is a method to this madness. - (if (and (boundp '*heap-exhausted-error-available-bytes*) - (boundp '*heap-exhausted-error-requested-bytes*)) - (format stream - ;; no pretty-printing, because that will use a lot of heap. - "Heap exhausted (no more space for allocation). -~D bytes available, ~D requested. - -PROCEED WITH CAUTION." - *heap-exhausted-error-available-bytes* - *heap-exhausted-error-requested-bytes*) - (format stream - "A ~S condition without bindings for heap statistics. (If -you did not expect to see this message, please report it." - 'heap-exhausted-error))))) - -(define-condition system-condition (condition) - ((address :initarg :address :reader system-condition-address :initform nil) - (context :initarg :context :reader system-condition-context :initform nil))) - -(define-condition memory-fault-error (system-condition error) () - (:report - (lambda (condition stream) - (format stream "Unhandled memory fault at #x~X." - (system-condition-address condition))))) - -(define-condition breakpoint-error (system-condition error) () - (:report - (lambda (condition stream) - (format stream "Unhandled breakpoint/trap at #x~X." - (system-condition-address condition))))) - -(define-condition interactive-interrupt (system-condition serious-condition) () - (:report - (lambda (condition stream) - (format stream "Interactive interrupt at #x~X." - (system-condition-address condition))))) diff -Nru sbcl-2.1.1/src/code/cross-early.lisp sbcl-2.1.11/src/code/cross-early.lisp --- sbcl-2.1.1/src/code/cross-early.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cross-early.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -116,7 +116,7 @@ (declaim (inline zerop)) (defun zerop (x) (if (rationalp x) (= x 0) (xfloat-zerop x))) -(defmethod make-load-form ((self target-num) &optional env) +(defmethod cl:make-load-form ((self target-num) &optional env) (declare (ignore env)) (if (complexp self) `(complex ,(complexnum-real self) ,(complexnum-imag self)) diff -Nru sbcl-2.1.1/src/code/cross-float.lisp sbcl-2.1.11/src/code/cross-float.lisp --- sbcl-2.1.1/src/code/cross-float.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cross-float.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -381,7 +381,7 @@ ((null value) ; must not be one of the exceptional symbols (setf (flonum-%value x) (calculate-flonum-value x))) (t ; infinity or minus-zero - (error "~S has no portable value" x))))) + (error "~S (~D) has no portable value" value x))))) (t (error "Got host float")))) (defun realnumify* (args) (mapcar #'realnumify args)) @@ -733,7 +733,7 @@ (eval-when (:compile-toplevel :execute) (setq sb-cold::*choke-on-host-irrationals* t)) -;;; These two constants are used in 'late-type' +;;; These two constants are used in 'type' (defconstant most-positive-long-float most-positive-double-float) (defconstant most-negative-long-float most-negative-double-float) @@ -758,7 +758,13 @@ `(let ((x (car args)) (y (cadr args))) (and (floatp x) (floatp y) (eql (flonum-%bits x) (flonum-%bits y))))) (two-zeros-p () - `(and (eql nargs 2) (zerop (car args)) (zerop (cadr args))))) + `(and (eql nargs 2) (zerop (car args)) (zerop (cadr args)))) + (same-sign-infinities-p () + `(and (eql nargs 2) + (floatp (car args)) + (floatp (cadr args)) + (member (flonum-%value (car args)) '(:-infinity :+infinity)) + (eq (flonum-%value (cadr args)) (flonum-%value (car args)))))) ;; Simple case of using the interceptor to return a boolean. If ;; infinity leaks in, the host will choke since those are @@ -833,6 +839,7 @@ (eql b $2.0d0)))) nil) ((two-zeros-p) t) ; signed zeros are equal + ((same-sign-infinities-p) t) ; infinities are = ((and (eql nargs 2) (zerop (cadr args))) ;; Need this case if the first arg is represented as bits (if (rationalp (car args)) @@ -861,6 +868,7 @@ (error "Unhandled"))) (error "Unhandled")))) ((two-zeros-p) t) ; signed zeros are equal + ((same-sign-infinities-p) t) ; infinities are = ((and (eql nargs 2) (zerop (cadr args))) ;; Need this case if the first arg is represented as bits (if (floatp (car args)) diff -Nru sbcl-2.1.1/src/code/cross-misc.lisp sbcl-2.1.11/src/code/cross-misc.lisp --- sbcl-2.1.1/src/code/cross-misc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cross-misc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -54,6 +54,29 @@ (defun set-symbol-global-value (sym val) (error "Can't set symbol-global-value: ~S ~S" sym val)) +(defun %defun (name lambda &optional inline-expansion) + (declare (ignore inline-expansion)) + (cl:proclaim `(ftype function ,name)) + (setf (fdefinition name) lambda)) + +(defun %defglobal (name value source-location &optional (doc nil docp)) + (declare (ignore source-location doc docp)) + (cl:proclaim `(special ,name)) + (setf (symbol-value name) value)) + +(defun %defparameter (var val source-location &optional (doc nil docp)) + (declare (ignore source-location doc docp)) + (cl:proclaim `(special ,var)) + (setf (symbol-value var) val)) + +(defun %defvar (var source-location &optional (val nil valp) (doc nil docp)) + (declare (ignore source-location doc docp)) + (cl:proclaim `(special ,var)) + (when (and valp (not (boundp var))) + (setf (symbol-value var) val))) + +(defun %boundp (symbol) (boundp symbol)) + ;;; The GENESIS function works with fasl code which would, in the ;;; target SBCL, work on ANSI-STREAMs (streams which aren't extended ;;; Gray streams). In ANSI Common Lisp, an ANSI-STREAM is just a @@ -222,6 +245,35 @@ (write structure :stream stream :circle t)) (in-package "SB-KERNEL") + +;;; These functions are required to emulate SBCL kernel functions +;;; in a vanilla ANSI Common Lisp cross-compilation host. +;;; The emulation doesn't need to be efficient, since it's needed +;;; only for object dumping. + +;; The set of structure types that we access by slot position at cross-compile +;; time is fairly small: +;; - DEFINITION-SOURCE-LOCATION +;; - DEFSTRUCT-DESCRIPTION, DEFSTRUCT-SLOT-DESCRIPTION +;; - DEBUG-SOURCE, COMPILED-DEBUG-INFO, COMPILED-DEBUG-FUN-{something} +;; - HEAP-ALIEN-INFO and ALIEN-{something}-TYPE +;; - COMMA +#-metaspace (defmacro wrapper-friend (x) x) +(defun %instance-wrapper (instance) + (declare (notinline classoid-wrapper)) + (classoid-wrapper (find-classoid (type-of instance)))) +(defun %instance-length (instance) + (declare (notinline wrapper-length)) + ;; In the target, it is theoretically possible to have %INSTANCE-LENGTH + ;; exceeed layout length, but in the cross-compiler they're the same. + (wrapper-length (%instance-wrapper instance))) +(defun %raw-instance-ref/word (instance index) + (declare (ignore instance index)) + (error "No such thing as raw structure access on the host")) +(defun layout-id (x) + (declare (notinline sb-kernel::wrapper-id)) + (sb-kernel::wrapper-id x)) + (defun %find-position (item seq from-end start end key test) (let ((position (position item seq :from-end from-end :start start :end end :key key :test test))) @@ -241,6 +293,11 @@ ;;; Mainly for the fasl loader (defun %fun-name (f) (nth-value 2 (function-lambda-expression f))) +(defun %svset (vector index val) ; stemming from toplevel (SETF SVREF) + (setf (aref vector index) val)) +(defun %puthash (key table val) ; stemming from toplevel (SETF GETHASH) + (setf (gethash key table) val)) + ;;;; Variables which have meaning only to the cross-compiler, defined here ;;;; in lieu of #+sb-xc-host elsewere which messes up toplevel form numbers. (in-package "SB-C") @@ -261,9 +318,9 @@ (let* ((n (length string)) (a (make-array n :element-type '(unsigned-byte 8)))) (dotimes (i n a) - (let ((code (sb-xc:char-code (char string i)))) + (let ((code (char-code (char string i)))) (unless (<= 0 code 127) - (setf code (sb-xc:char-code #\?))) + (setf code (char-code #\?))) (setf (aref a i) code))))) ;;;; Stubs for host @@ -273,91 +330,13 @@ `(lambda ,@(cddr lambda)) lambda))) -(defun sb-impl::%defun (name lambda &optional inline-expansion) - (declare (ignore inline-expansion)) - (proclaim `(ftype function ,name)) - (setf (fdefinition name) (eval lambda))) - -(defun %svset (vector index val) ; stemming from toplevel (SETF SVREF) - (setf (aref vector index) val)) -(defun %puthash (key table val) ; stemming from toplevel (SETF GETHASH) - (setf (gethash key table) val)) - ;;; The compiler calls this with forms in EVAL-WHEN (:COMPILE-TOPLEVEL) situations. -;;; Since we've already performed macroexpansion using our macros, we can either -;;; implement target-compatible functions for all things into which we might expand, -;;; or we can un-macro-expand the form. This does a little of both, -;;; mainly for the sake of showing that it's quite easily done. -;;; Truth be told I'd have preferred to use the anti-expansion technique consistently, -;;; however occasionally we see things like (LET ((V FROB)) (%SVSET *THING* X V)) -;;; which means that the host is going to do the LET and then call %SVSET. (defun eval-tlf (form index &optional lexenv) (declare (ignore index lexenv)) - (flet ((matchp (template form &aux results) - (if (named-let recurse ((form form) (template template)) - (typecase template - (null (null form)) - ((eql ?) (push form results) t) ; match and store anything - ((eql :ignore) t) ; match anything and disregard - ((cons (eql :or)) - (some (lambda (template) - (recurse form template)) - (cdr template))) - (cons (and (consp form) - (and (recurse (car form) (car template)) - (recurse (cdr form) (cdr template))))) - (t (eql template form)))) ; match template exactly - (nreverse results) - (error "Pattern match failure: ~S~% ~S~%" template form)))) - ;; Note that in all cases below, the package lock on CL prevents - ;; accidental appearance of a CL symbol as a thing being defined. - (named-let recurse ((form form)) - (case (car form) - (progn (mapc #'recurse (cdr form))) ; compiler doesn't care about return value - (t - (eval - (case (car form) - (sb-impl::%defglobal - (destructuring-bind (symbol value) - (matchp '((quote ?) (if (%boundp :ignore) :ignore ?)) (cdr form)) - `(defvar ,symbol ,value))) - (sb-impl::%defparameter - (destructuring-bind (symbol value) - (matchp '((quote ?) ? :ignore) (cdr form)) - `(defparameter ,symbol ,value))) - (sb-impl::%defvar - (destructuring-bind (symbol value) ; always occurs with a value - (matchp '((quote ?) (source-location) (:or (unless (%boundp :ignore) ?) ?)) - (cdr form)) - `(defvar ,symbol ,value))) - (sb-c::%defconstant - ;; There is genuinely ambiguity here - does :COMPILE-TOPLEVEL situation for - ;; DEFCONSTANT mean that we want the host compiler to know the constant? - ;; It must, because the standard specifies that defconstant need not be within - ;; EVAL-WHEN for the compiler to know it. But because of how our defconstant - ;; expands - calling %defconstant inside of an eval-when listing all 3 - ;; situations - we can't discern whether this is our defconstant doing its - ;; normal thing, versus inside an explicity written eval-when with intent - ;; to convey the constant to the host - perhaps because of a DEFUN also inside - ;; an eval-when where we need the host to reference the constant. - ;; Therefore every constant has to be made known to the host under the - ;; assumption that it needs it, AND the cross-compiler under the assumption - ;; that this is our normal :compile-toplevel handling. - (destructuring-bind (symbol value) (matchp '((quote ?) ? . :ignore) (cdr form)) - `(progn (defconstant ,symbol ,value) - (sb-c::%defconstant ',symbol ,symbol nil)))) - (defconstant ; we see this macro as well. The host expansion will not do, - ;; because it calls our %defconstant which does not assign the symbol a value. - ;; It might be possible to change that now that we don't use CL: symbols. - (destructuring-bind (symbol value) (cdr form) - `(progn (defconstant ,symbol ,value) - (sb-c::%defconstant ',symbol ,symbol nil)))) - (t - form)))))))) + (eval form)) (defmacro sb-format:tokens (string) string) -;;; For a use in EARLY-TYPE (defmacro with-system-mutex ((lock) &body body) (declare (ignore lock)) `(progn ,@body)) @@ -376,3 +355,5 @@ ;; Let's suppose that the host lisp knows what it's doing to efficiently ;; compile the standard macro. Don't try to outdo it. `(with-output-to-string (,var) ,@body)) + +(defun source-location ()) diff -Nru sbcl-2.1.1/src/code/cross-modular.lisp sbcl-2.1.11/src/code/cross-modular.lisp --- sbcl-2.1.1/src/code/cross-modular.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cross-modular.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -55,3 +55,30 @@ (defun sb-vm::ash-left-modfx (integer amount) (mask-signed-field (- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits) (ash integer amount))) + +;;;; these cross-compiler compatibility functions have vops for +;;;; the target machine. +;;;; COUNT is regarded as having either 5 (for 32-machines) or 6 +;;;; (for 64-bit machines) significant bits. Excess bits must be ignored +;;;; either explicitly in the vops (arm[64], ppc[64]) or by the CPU +;;;; (x86, sparc, mips, riscv). + +;;; Shift NUMBER by the low-order bits of COUNT, adding zero bits +;;; at the "end" and removing bits from the "start". On big-endian +;;; machines this is a left-shift and on little-endian machines this +;;; is a right-shift. +(defun shift-towards-start (number count) + (declare (type word number) (fixnum count)) + (let ((count (ldb (byte (1- (integer-length sb-vm:n-word-bits)) 0) count))) + #+big-endian (logand (ash number count) most-positive-word) + #+little-endian (ash number (- count)))) + +;;; Shift NUMBER by the low-order bits of COUNT, adding zero bits +;;; at the "start" and removing bits from the "end". On big-endian +;;; machines this is a right-shift and on little-endian machines this +;;; is a left-shift. +(defun shift-towards-end (number count) + (declare (type word number) (fixnum count)) + (let ((count (ldb (byte (1- (integer-length sb-vm:n-word-bits)) 0) count))) + #+big-endian (ash number (- count)) + #+little-endian (logand (ash number count) most-positive-word))) diff -Nru sbcl-2.1.1/src/code/cross-type.lisp sbcl-2.1.11/src/code/cross-type.lisp --- sbcl-2.1.1/src/code/cross-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/cross-type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -82,7 +82,7 @@ ;;; The logic is a mixture of the code for CTYPEP and %%TYPEP ;;; because it handles both. ;;; The order of clauses is fairly symmetrical with that of %%TYPEP. -(defvar *xtypep-uncertainty-action* 'warn) ; {BREAK WARN STYLE-WARN ERROR NIL} +(defvar *xtypep-uncertainty-action* #-sb-devel 'warn #+sb-devel nil) ; {BREAK WARN STYLE-WARN ERROR NIL} (macrolet ((unimplemented () '(bug "Incomplete implementation of ~S ~S ~S" caller obj type)) (uncertain () @@ -137,7 +137,7 @@ #+sb-simd-pack-256 simd-pack-256-type) (values nil t)) (character-set-type - ;; provided that SB-XC:CHAR-CODE doesn't fail, the answer is certain + ;; provided that CHAR-CODE doesn't fail, the answer is certain (values (test-character-type type) t)) (classoid ; = {built-in,structure,condition,standard,static}-classoid (let ((name (classoid-name type))) @@ -161,7 +161,7 @@ ;; and it's in our object hierarchy (cl:subtypep name 'structure!object)) (values (cl:typep obj name) t) - (unimplemented))))))) + (unimplemented))))))) (fun-type (if (fun-designator-type-p type) (values (typep obj '(or symbol function)) t) @@ -172,7 +172,7 @@ (if (and (functionp obj) (eq caller 'sb-xc:typep)) (error "TYPEP called with function type") (values (functionp obj) t)))) - (alien-type-type (if (null obj) (values nil t) (unimplemented))) + (alien-type-type (if (symbolp obj) (values nil t) (unimplemented))) ;; Test UNKNOWN before falling into the HAIRY case (unknown-type (let ((spec (unknown-type-specifier type))) @@ -241,6 +241,10 @@ ;; Keep in sync with KEYWORDP test in src/code/target-type (cond ((eq predicate 'keywordp) (test-keywordp)) + ;; These are needed in order to compile the predicates + ;; for the initial pprint dispatch table. + ((and (eq obj nil) (member predicate '(fboundp macro-function))) + (values nil t)) ((acceptable-cross-typep-pred predicate caller) (values (funcall predicate obj) t)) (t @@ -309,6 +313,7 @@ (and (boundp 'sb-c::*compilation*) (eq (sb-c::block-compile sb-c::*compilation*) t))) (values answer certain) + #-sb-devel (warn 'cross-type-giving-up :call `(ctypep ,obj ,ctype))))) (defun ctype-of (x) @@ -345,13 +350,13 @@ ;; Beyond this, there seems to be no portable correspondence. (error "can't map host Lisp CHARACTER ~S to target Lisp" x)))) (sb-c::opaque-box (find-classoid 'structure-object)) - (instance - (let ((type (type-of x))) - (if (eq type 'sb-format::fmt-control-proxy) - ;; These are functions, but they're weird. We don't want any IR1 transform - ;; on FORMAT to kick in and try to convert to FUNCALL on the thing. - (specifier-type '(or string function)) - (find-classoid type)))) + (instance + (let ((type (type-of x))) + (if (eq type 'sb-format::fmt-control-proxy) + ;; These are functions, but they're weird. We don't want any IR1 transform + ;; on FORMAT to kick in and try to convert to FUNCALL on the thing. + (specifier-type '(or string function)) + (find-classoid type)))) (t ;; There might be more cases which we could handle with ;; sufficient effort; since all we *need* to handle are enough diff -Nru sbcl-2.1.1/src/code/debug-info.lisp sbcl-2.1.11/src/code/debug-info.lisp --- sbcl-2.1.1/src/code/debug-info.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/debug-info.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -390,14 +390,6 @@ (created nil :type (or unsigned-byte null)) ;; Additional information from (WITH-COMPILATION-UNIT (:SOURCE-PLIST ...)) (plist *source-plist* :read-only t)) -(def!struct (core-debug-source (:pure t) - (:copier nil) - (:include debug-source)) - ;; Compilation to memory stores each toplevel form given to %COMPILE. - ;; That form can generate multiple functions, and those functions can - ;; be in one or more code components. They all point at the same form. - form - (function nil :read-only t)) ;;;; DEBUG-INFO structures @@ -420,7 +412,7 @@ (contexts nil :type t :read-only t) ;; Packed integers. Also can be a cons of that plus an alist which ;; maps SB-C::COMPILED-DEBUG-FUN to SB-DI::COMPILED-DEBUG-FUN instances. - (tlf-num+offset nil :type (or integer cons))) + (tlf-num+offset (missing-arg) :type (or integer cons))) ;;; The TLF-NUMBER and CHAR-OFFSET of a compiled-debug-info can each be NIL, ;;; but aren't often. However, to allow that, convert NIL to 0 and non-nil @@ -447,17 +439,18 @@ (:copier nil) (:print-object (lambda (s stream) (print-unreadable-object (s stream :type t) - (princ (file-info-name s) stream))))) + (princ (file-info-truename s) stream))))) ;; If a file, the truename of the corresponding source file. If from - ;; a Lisp form, :LISP. If from a stream, :STREAM. - (name (missing-arg) :type (or pathname (eql :lisp)) :read-only t) + ;; a Lisp form, :LISP. In COMPILE-FILE, this gets filled lazily + ;; after the file gets opened. + (truename nil :type (or pathname null (eql :lisp))) ;; the external format that we'll call OPEN with, if NAME is a file. (external-format nil :read-only t) ;; the defaulted, but not necessarily absolute file name (i.e. prior ;; to TRUENAME call.) Null if not a file. This is used to set ;; *COMPILE-FILE-PATHNAME*, and if absolute (a harmful constraint to be sure), ;; is dumped in the debug-info. - (untruename nil :type (or pathname null) :read-only t) + (pathname nil :type (or pathname null) :read-only t) ;; the file's write date (if relevant) (write-date nil :type (or unsigned-byte null) :read-only t) ;; parallel vectors containing the forms read out of the file and diff -Nru sbcl-2.1.1/src/code/debug-int.lisp sbcl-2.1.11/src/code/debug-int.lisp --- sbcl-2.1.1/src/code/debug-int.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/debug-int.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,6 +12,15 @@ (in-package "SB-DI") +(defstruct (sb-c::core-debug-source (:pure t) + (:copier nil) + (:include debug-source)) + ;; Compilation to memory stores each toplevel form given to %COMPILE. + ;; That form can generate multiple functions, and those functions can + ;; be in one or more code components. They all point at the same form. + form + (function nil :read-only t)) + ;;; FIXME: There are an awful lot of package prefixes in this code. ;;; Couldn't we have SB-DI use the SB-C and SB-VM packages? @@ -612,13 +621,14 @@ ;;; to malloc() in that regard. (defun code-header-from-pc (pc) - (declare (system-area-pointer pc)) (with-code-pages-pinned (:dynamic) (let ((base-ptr (sb-alien:alien-funcall (sb-alien:extern-alien "component_ptr_from_pc" (function sb-alien:unsigned system-area-pointer)) - pc))) + (etypecase pc + (system-area-pointer pc) + (sb-vm:word (int-sap pc)))))) (unless (= base-ptr 0) (%make-lisp-obj (logior base-ptr sb-vm:other-pointer-lowtag)))))) @@ -847,7 +857,7 @@ ;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp ;;; calls into C. In this case, the code object is stored on the stack ;;; after the LRA, and the LRA is the word offset. -#-(or x86 x86-64) +#-(or x86 x86-64 arm64) (defun compute-calling-frame (caller lra up-frame &optional savedp) (declare (type system-area-pointer caller) (ignore savedp)) @@ -899,7 +909,42 @@ escaped) (if up-frame (1+ (frame-number up-frame)) 0) escaped)))))) - +#+arm64 +(defun compute-calling-frame (caller lra up-frame &optional savedp) + (declare (type system-area-pointer caller) + (ignore savedp)) + (when (control-stack-pointer-valid-p caller) + (multiple-value-bind (code pc-offset escaped) + (if lra + (let* ((lr (int-sap (ash lra n-fixnum-tag-bits))) + (code (code-header-from-pc lr))) + (values code + (if code + (sap- lr (code-instructions code)) + 0))) + (find-escaped-frame caller)) + (if (and (code-component-p code) + (eq (%code-debug-info code) :bpt-lra)) + (let ((real-lra (code-header-ref code real-lra-slot))) + (compute-calling-frame caller real-lra up-frame)) + (let ((d-fun (case code + (:undefined-function + (make-bogus-debug-fun + "undefined function")) + (:foreign-function + (make-bogus-debug-fun + (foreign-function-backtrace-name + (int-sap (get-lisp-obj-address lra))))) + ((nil) + (make-bogus-debug-fun + "bogus stack frame")) + (t + (debug-fun-from-pc code pc-offset escaped))))) + (make-compiled-frame caller up-frame d-fun + (code-location-from-pc d-fun pc-offset + escaped) + (if up-frame (1+ (frame-number up-frame)) 0) + escaped)))))) #+(or x86 x86-64) (defun compute-calling-frame (caller ra up-frame &optional savedp) (declare (type system-area-pointer caller ra)) @@ -1105,12 +1150,12 @@ ;;; Find the code object corresponding to the object represented by ;;; bits and return it. We assume bogus functions correspond to the ;;; undefined-function. -#+(or x86 x86-64) +#+(or x86 x86-64 arm64) (defun code-object-from-context (context) (declare (type (sb-alien:alien (* os-context-t)) context)) (code-header-from-pc (context-pc context))) -#-(or x86 x86-64) +#-(or x86 x86-64 arm64) (defun code-object-from-context (context) (declare (type (sb-alien:alien (* os-context-t)) context)) ;; The GC constraint on the program counter on precisely-scavenged @@ -1253,7 +1298,7 @@ (fp (frame-pointer frame))) (labels ((catch-ref (slot) (sap-ref-lispobj catch (* slot n-word-bytes))) - #-(or x86 x86-64) + #-(or x86 x86-64 arm64) (catch-entry-offset () (let* ((lra (catch-ref catch-block-entry-pc-slot)) (component (catch-ref catch-block-code-slot)) @@ -1263,7 +1308,7 @@ (* (- (1+ (get-header-data lra)) (code-header-words component)) n-word-bytes))) - #+(or x86 x86-64) + #+(or x86 x86-64 arm64) (catch-entry-offset () (let* ((ra (sap-ref-sap catch (* catch-block-entry-pc-slot @@ -1323,7 +1368,7 @@ ;;; DEBUG-BLOCK information. (defmacro do-debug-fun-blocks ((block-var debug-fun &optional result) &body body) - (let ((blocks (gensym)) + (let ((blocks (sb-xc:gensym)) (i (gensym))) `(let ((,blocks (debug-fun-debug-blocks ,debug-fun))) (declare (simple-vector ,blocks)) @@ -2402,6 +2447,72 @@ #-(or x86 x86-64) (#.sb-vm:interior-reg-sc-number (error "Local interior register access?")) + #+sb-simd-pack + ((#.sb-vm::sse-reg-sc-number #.sb-vm::int-sse-reg-sc-number) + (escaped-float-value simd-pack-int)) + #+sb-simd-pack + ((#.sb-vm::single-sse-reg-sc-number) + (escaped-float-value simd-pack-single)) + #+sb-simd-pack + ((#.sb-vm::double-sse-reg-sc-number) + (escaped-float-value simd-pack-double)) + #+sb-simd-pack + ((#.sb-vm::int-sse-stack-sc-number) + (with-nfp (nfp) + (%make-simd-pack-ub64 + (sap-ref-64 nfp (number-stack-offset 0)) + (sap-ref-64 nfp (number-stack-offset 8))))) + #+sb-simd-pack + ((#.sb-vm::single-sse-stack-sc-number) + (with-nfp (nfp) + (%make-simd-pack-single + (sap-ref-single nfp (number-stack-offset 0)) + (sap-ref-single nfp (number-stack-offset 4)) + (sap-ref-single nfp (number-stack-offset 8)) + (sap-ref-single nfp (number-stack-offset 12))))) + #+sb-simd-pack + ((#.sb-vm::double-sse-stack-sc-number) + (with-nfp (nfp) + (%make-simd-pack-double + (sap-ref-double nfp (number-stack-offset 0)) + (sap-ref-double nfp (number-stack-offset 8))))) + #+sb-simd-pack-256 + ((#.sb-vm::ymm-reg-sc-number #.sb-vm::int-avx2-reg-sc-number) + (escaped-float-value simd-pack-256-int)) + #+sb-simd-pack-256 + ((#.sb-vm::single-avx2-reg-sc-number) + (escaped-float-value simd-pack-256-single)) + #+sb-simd-pack-256 + ((#.sb-vm::double-avx2-reg-sc-number) + (escaped-float-value simd-pack-256-double)) + #+sb-simd-pack-256 + ((#.sb-vm::int-avx2-stack-sc-number) + (with-nfp (nfp) + (%make-simd-pack-256-ub64 + (sap-ref-64 nfp (number-stack-offset 0)) + (sap-ref-64 nfp (number-stack-offset 8)) + (sap-ref-64 nfp (number-stack-offset 16)) + (sap-ref-64 nfp (number-stack-offset 24))))) + #+sb-simd-pack-256 + ((#.sb-vm::single-avx2-stack-sc-number) + (with-nfp (nfp) + (%make-simd-pack-256-single + (sap-ref-single nfp (number-stack-offset 0)) + (sap-ref-single nfp (number-stack-offset 4)) + (sap-ref-single nfp (number-stack-offset 8)) + (sap-ref-single nfp (number-stack-offset 12)) + (sap-ref-single nfp (number-stack-offset 16)) + (sap-ref-single nfp (number-stack-offset 20)) + (sap-ref-single nfp (number-stack-offset 24)) + (sap-ref-single nfp (number-stack-offset 28))))) + #+sb-simd-pack-256 + ((#.sb-vm::double-avx2-stack-sc-number) + (with-nfp (nfp) + (%make-simd-pack-256-double + (sap-ref-double nfp (number-stack-offset 0)) + (sap-ref-double nfp (number-stack-offset 8)) + (sap-ref-double nfp (number-stack-offset 16)) + (sap-ref-double nfp (number-stack-offset 24))))) (#.sb-vm:single-reg-sc-number (escaped-float-value single-float)) (#.sb-vm:double-reg-sc-number @@ -2460,9 +2571,10 @@ (sap-ref-sap nfp (number-stack-offset)))) (#.constant-sc-number (if escaped - (code-header-ref - (code-header-from-pc (sb-vm:context-pc escaped)) - (sb-c:sc+offset-offset sc+offset)) + (let ((code (code-header-from-pc (sb-vm:context-pc escaped)))) + (if code + (code-header-ref code (sb-c:sc+offset-offset sc+offset)) + :invalid-code-object-at-pc)) :invalid-value-for-unescaped-register-storage)) (#.immediate-sc-number (sb-c:sc+offset-offset sc+offset))))) @@ -2471,7 +2583,7 @@ ;;; COMPILED-DEBUG-VAR case, access the current value to determine if ;;; it is an indirect value cell. This occurs when the variable is ;;; both closed over and set. -(defun %set-debug-var-value (debug-var frame new-value) +(defun (setf debug-var-value) (new-value debug-var frame) (aver (typep frame 'compiled-frame)) (let ((old-value (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p old-value) @@ -2573,6 +2685,72 @@ #-(or x86 x86-64) (#.sb-vm:interior-reg-sc-number (error "Local interior register access?")) + #+sb-simd-pack + ((#.sb-vm::sse-reg-sc-number #.sb-vm::int-sse-reg-sc-number) + (set-escaped-float-value simd-pack-int value)) + #+sb-simd-pack + ((#.sb-vm::single-sse-reg-sc-number) + (set-escaped-float-value simd-pack-single value)) + #+sb-simd-pack + ((#.sb-vm::double-sse-reg-sc-number) + (set-escaped-float-value simd-pack-double value)) + #+sb-simd-pack + ((#.sb-vm::int-sse-stack-sc-number) + (multiple-value-bind (a b) (%simd-pack-ub64s value) + (with-nfp (nfp) + (setf (sap-ref-64 nfp (number-stack-offset 0)) a + (sap-ref-64 nfp (number-stack-offset 8)) b)))) + #+sb-simd-pack + ((#.sb-vm::single-sse-stack-sc-number) + (multiple-value-bind (a b c d) (%simd-pack-singles value) + (with-nfp (nfp) + (setf (sap-ref-single nfp (number-stack-offset 0)) a + (sap-ref-single nfp (number-stack-offset 4)) b + (sap-ref-single nfp (number-stack-offset 8)) c + (sap-ref-single nfp (number-stack-offset 12)) d)))) + #+sb-simd-pack + ((#.sb-vm::double-sse-stack-sc-number) + (multiple-value-bind (a b) (%simd-pack-doubles value) + (with-nfp (nfp) + (setf (sap-ref-double nfp (number-stack-offset 0)) a + (sap-ref-double nfp (number-stack-offset 8)) b)))) + #+sb-simd-pack-256 + ((#.sb-vm::ymm-reg-sc-number #.sb-vm::int-avx2-reg-sc-number) + (set-escaped-float-value simd-pack-256-int value)) + #+sb-simd-pack-256 + ((#.sb-vm::single-avx2-reg-sc-number) + (set-escaped-float-value simd-pack-256-single value)) + #+sb-simd-pack-256 + ((#.sb-vm::double-avx2-reg-sc-number) + (set-escaped-float-value simd-pack-256-double value)) + #+sb-simd-pack-256 + ((#.sb-vm::int-avx2-stack-sc-number) + (with-nfp (nfp) + (multiple-value-bind (a b c d) (%simd-pack-256-ub64s value) + (setf (sap-ref-64 nfp (number-stack-offset 0)) a + (sap-ref-64 nfp (number-stack-offset 8)) b + (sap-ref-64 nfp (number-stack-offset 16)) c + (sap-ref-64 nfp (number-stack-offset 24)) d)))) + #+sb-simd-pack-256 + ((#.sb-vm::single-avx2-stack-sc-number) + (multiple-value-bind (a b c d e f g h) (%simd-pack-256-singles value) + (with-nfp (nfp) + (setf (sap-ref-single nfp (number-stack-offset 0)) a + (sap-ref-single nfp (number-stack-offset 4)) b + (sap-ref-single nfp (number-stack-offset 8)) c + (sap-ref-single nfp (number-stack-offset 12)) d + (sap-ref-single nfp (number-stack-offset 16)) e + (sap-ref-single nfp (number-stack-offset 20)) f + (sap-ref-single nfp (number-stack-offset 24)) g + (sap-ref-single nfp (number-stack-offset 28)) h)))) + #+sb-simd-pack-256 + ((#.sb-vm::double-avx2-stack-sc-number) + (multiple-value-bind (a b c d) (%simd-pack-256-doubles value) + (with-nfp (nfp) + (setf (sap-ref-double nfp (number-stack-offset 0)) a + (sap-ref-double nfp (number-stack-offset 8)) b + (sap-ref-double nfp (number-stack-offset 16)) c + (sap-ref-double nfp (number-stack-offset 24)) d)))) (#.sb-vm:single-reg-sc-number #-(or x86 x86-64) ;; don't have escaped floats. (set-escaped-float-value single-float value)) @@ -2642,7 +2820,8 @@ #-(or x86 x86-64) (the long-float (realpart value))))) (#.sb-vm:control-stack-sc-number - (setf (stack-ref fp (sb-c:sc+offset-offset sc+offset)) value)) + (%set-stack-ref fp (sb-c:sc+offset-offset sc+offset) value) + value) ; I doubt that the return value matters, but who knows ... (#.sb-vm:character-stack-sc-number (with-nfp (nfp) (setf (sap-ref-word nfp (number-stack-offset 0)) @@ -3244,11 +3423,12 @@ ;;; is SETF'able. (defun breakpoint-info (breakpoint) (breakpoint-%info breakpoint)) -(defun %set-breakpoint-info (breakpoint value) +(defun (setf breakpoint-info) (value breakpoint) (setf (breakpoint-%info breakpoint) value) (let ((other (breakpoint-unknown-return-partner breakpoint))) (when other - (setf (breakpoint-%info other) value)))) + (setf (breakpoint-%info other) value))) + value) ;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT @@ -3484,7 +3664,10 @@ ;;; state of the program, not merely a return PC location. ;;; (I tried changing this to DEFUN-CACHED, which failed a regression test) (defun make-bpt-lra (real-lra) - (declare (type #-(or x86 x86-64) lra #+(or x86 x86-64) system-area-pointer real-lra)) + (declare (type #-(or x86 x86-64 arm64) lra #+(or x86 x86-64 arm64) system-area-pointer real-lra)) + real-lra + #+arm64 (error "Breakpoints do not work on ARM64") + #-arm64 (macrolet ((symbol-addr (name) `(find-dynamic-foreign-symbol-address ,name)) (trap-offset () @@ -3495,48 +3678,53 @@ (length (the index (- (symbol-addr "fun_end_breakpoint_end") src-start))) (code-object - (sb-c:allocate-code-object - nil 0 - ;; For non-x86: a single boxed constant holds the true LRA. - ;; For x86[-64]: one boxed constant holds the code object to which - ;; to return, and one holds the displacement into that object. - ;; Ensure required boxed header alignment. - (align-up (+ sb-vm:code-constants-offset 1 #+(or x86-64 x86) 1) - sb-c::code-boxed-words-align) - ;; 2 extra raw bytes represent CODE-N-ENTRIES (which is zero) - (+ length 2)))) + (sb-c:allocate-code-object + nil 0 + ;; For non-x86: a single boxed constant holds the true LRA. + ;; For x86[-64]: one boxed constant holds the code object to which + ;; to return, and one holds the displacement into that object. + ;; Ensure required boxed header alignment. + (align-up (+ sb-vm:code-constants-offset 1 #+(or x86-64 x86) 1) + sb-c::code-boxed-words-align) + (+ length + sb-vm:n-word-bytes ; Jump Table prefix word + ;; Alignment padding, LRA header + #-(or x86 x86-64) (* 2 sb-vm:n-word-bytes) + ;; 2 extra raw bytes represent CODE-N-ENTRIES (which is zero) + 2)))) (setf (%code-debug-info code-object) :bpt-lra) (with-pinned-objects (code-object) - (system-area-ub8-copy (int-sap src-start) 0 - (code-instructions code-object) 0 length)) - #+(or x86 x86-64) - (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra) - (setf (code-header-ref code-object real-lra-slot) code - (code-header-ref code-object (1+ real-lra-slot)) offset) - ;; Holy hell, returning a SAP looks GC-unsafe, but it's OK. - ;; It points into CODE-OBJECT which is implicitly pinned. - ;; WITHOUT-GCING which formerly enclosed this function was disingenuous - ;; because we escaped from its scope when returning the SAP. - (values (code-instructions code-object) code-object (trap-offset))) - #-(or x86 x86-64) - (progn - ;; We used to set the header value of the LRA here to the - ;; offset from the enclosing component to the LRA header, but - ;; MAKE-LISP-OBJ actually checks the value before we get a - ;; chance to set it, so it's now done in arch-assem.S. - ;; KLUDGE: The preceding concern is rendered irrelevant by - ;; use of unsafe %MAKE-LISP-OBJ, but we do still copy the lisp header - ;; from arch-assem.S which is horrible. Either that assembly code - ;; should be emitted as Lisp asm routine so that it has access to - ;; SB-VM:CODE-CONSTANTS-OFFSET, or we should emit the header. - ;; The issue is that the backpointer (word count) from the LRA to - ;; its containing code object has to be right. - (setf (code-header-ref code-object real-lra-slot) real-lra) - (values (with-pinned-objects (code-object) - (%make-lisp-obj (logior (sap-int (code-instructions code-object)) - sb-vm:other-pointer-lowtag))) - (sb-vm:sanctify-for-execution code-object) - (trap-offset)))))) + #+(or x86 x86-64 arm64) + (let ((instructions ; Don't touch the jump table prefix word + (sap+ (code-instructions code-object) sb-vm:n-word-bytes))) + (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra) + (setf (code-header-ref code-object real-lra-slot) code + (code-header-ref code-object (1+ real-lra-slot)) offset) + (system-area-ub8-copy (int-sap src-start) 0 instructions 0 length) + ;; CODE-OBJECT is implicitly pinned after leaving WITH-PINNED-OBJECTS + ;; (and would be pinned even if the W-P-O were deleted), so we're OK + ;; to return a SAP to the instructions. + ;; TRAP-OFFSET is the distance from CODE-INSTRUCTIONS to the trapping + ;; opcode, for which we have to account for the jump table prefix word. + (values instructions code-object (+ (trap-offset) sb-vm:n-word-bytes)))) + #-(or x86 x86-64 arm64) + (let* ((lra-header-addr + ;; Skip over the jump table prefix, and align properly for LRA header + (sap+ (code-instructions code-object) (* 2 sb-vm:n-word-bytes))) + ;; Compute the LRA->code backpointer in words + (delta (ash (sap- lra-header-addr + (int-sap (logandc2 (get-lisp-obj-address code-object) + sb-vm:lowtag-mask))) + (- sb-vm:word-shift)))) + (setf (code-header-ref code-object real-lra-slot) real-lra) + (setf (sap-ref-word lra-header-addr 0) + (logior (ash delta sb-vm:n-widetag-bits) sb-vm:return-pc-widetag)) + (system-area-ub8-copy (int-sap src-start) 0 + (sap+ lra-header-addr sb-vm:n-word-bytes) + 0 length) + (values (%make-lisp-obj (logior (sap-int lra-header-addr) sb-vm:other-pointer-lowtag)) + (sb-vm:sanctify-for-execution code-object) + (+ (trap-offset) (* 3 sb-vm:n-word-bytes)))))))) ;;;; miscellaneous diff -Nru sbcl-2.1.1/src/code/debug.lisp sbcl-2.1.11/src/code/debug.lisp --- sbcl-2.1.1/src/code/debug.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/debug.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -62,7 +62,7 @@ ;;; If this is bound before the debugger is invoked, it is used as the stack ;;; top by the debugger. It can either be the first interesting frame, or the ;;; name of the last uninteresting frame. -(defparameter *stack-top-hint* nil) ; initialized by genesis +(defvar *stack-top-hint* nil) (defvar *current-frame* nil) (declaim (always-bound *stack-top-hint* *current-frame*)) @@ -918,11 +918,19 @@ ;; until bug 403 is fixed, PPRINT-LOGICAL-BLOCK (STREAM NIL) is ;; definitely preferred, because the FORMAT alternative was acting odd. (pprint-logical-block (stream nil) + #-sb-thread + (format stream "debugger invoked on a ~S: ~2I~_~A" (type-of condition) condition) + #+sb-thread (format stream - "debugger invoked on a ~S~@[ in thread ~_~A~]: ~2I~_~A" + "debugger invoked on a ~S~@[ @~x~] in thread ~_~A: ~2I~_~A" (type-of condition) - #+sb-thread sb-thread:*current-thread* - #-sb-thread nil + (when (boundp '*current-internal-error-context*) + (if (system-area-pointer-p *current-internal-error-context*) + (sb-alien:with-alien ((context (* os-context-t) + sb-kernel:*current-internal-error-context*)) + (sap-int (sb-vm:context-pc context))) + (sap-int (sb-vm:context-pc *current-internal-error-context*)))) + sb-thread:*current-thread* condition)) (terpri stream)) @@ -1810,6 +1818,8 @@ (funcall thunk)) #+unbind-in-unwind thunk #+unbind-in-unwind unbind-to + #+(and unbind-in-unwind (not c-stack-is-control-stack)) + (%primitive sb-c:current-nsp) #+unbind-in-unwind catch-block))) #-unwind-to-frame-and-call-vop (let ((tag (gensym))) diff -Nru sbcl-2.1.1/src/code/debug-var-io.lisp sbcl-2.1.11/src/code/debug-var-io.lisp --- sbcl-2.1.1/src/code/debug-var-io.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/debug-var-io.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -124,6 +124,27 @@ (defun integer-from-octets (octets) (declare (type (array (unsigned-byte 8) (*)) octets)) + #-sb-xc-host (aver (array-header-p octets)) + + ;; Bignums are little-endian by word, but native-endian within each word, + ;; making use of the less consy algorithm too tricky for big-endian CPUs. + ;; And this does not work for little-endian, but I don't know why. + ;; It should not be too hard to use random testing to find an input + ;; at which the output obviously differs from the shift+add loop. + #+nil + (let ((input (%array-data octets))) + (if (typep (%vector-raw-bits input 0) 'fixnum) + (%vector-raw-bits input 0) + (let* ((nbytes (length octets)) + (last-byte (if (plusp nbytes) (aref octets (1- nbytes)) 0)) + ;; If the high bit of the highest byte is 1, we might need one more + ;; byte to avoid the bignum coming out negative. + (nbits (* (+ nbytes (ash last-byte -7)) sb-vm:n-byte-bits)) + (ndigits (ceiling nbits sb-vm:n-word-bits)) + (bignum (sb-bignum:%allocate-bignum ndigits))) + (dotimes (i ndigits (sb-bignum::%normalize-bignum bignum ndigits)) + (setf (%bignum-ref bignum i) (%vector-raw-bits input i)))))) + (let ((result 0) (shift 0)) (dovector (byte octets result) (setf result (logior result (ash byte shift)) @@ -143,11 +164,13 @@ ;;; the code that could not be deduced by examining the object. ;;; It makes sense to store these externally to the object, as it would otherwise ;;; intrude on text pages. Also, some of the bignums are shareable this way. -(defun pack-code-fixup-locs (abs-fixups rel-fixups) - (let ((bytes (make-array (* 2 (+ (length abs-fixups) ; guess at final length - (length rel-fixups))) - :fill-pointer 0 :adjustable t - :element-type '(unsigned-byte 8)))) +(defun pack-code-fixup-locs (abs-fixups rel-fixups more) + (dx-let ((bytes (make-array (min (* 2 (+ (length abs-fixups) ; guess at final length + (length rel-fixups) + (length more))) + 1024) ; limit the stack usage + :fill-pointer 0 :adjustable t + :element-type '(unsigned-byte 8)))) (flet ((pack (list &aux (prev 0)) (dolist (x list) ;; two fixups at the same location have to be wrong, @@ -156,9 +179,12 @@ (write-var-integer (- x prev) bytes) (setq prev x)))) (pack (sort abs-fixups #'<)) - (when rel-fixups + (when (or rel-fixups more) + (write-var-integer 0 bytes) + (pack (sort rel-fixups #'<))) + (when more (write-var-integer 0 bytes) - (pack (sort rel-fixups #'<)))) + (pack (sort more #'<)))) ;; Stuff octets into an integer ;; It would be quite possible in the target to do something clever here ;; by creating a bignum directly from the ub8 vector. @@ -189,12 +215,14 @@ (let ((,loc (+ ,prev ,acc))) ,@body (setq ,prev ,loc)) (setq ,acc 0 ,shift 0)))))))) +;;; Unpack the (potentially) three stream of data in PACKED-INTEGER. (defun unpack-code-fixup-locs (packed-integer) - (collect ((abs-locs) (rel-locs)) + (collect ((stream1) (stream2) (stream3)) (let ((pos 0)) - (do-packed-varints (loc packed-integer pos) (abs-locs loc)) - (do-packed-varints (loc packed-integer pos) (rel-locs loc))) - (values (abs-locs) (rel-locs)))) + (do-packed-varints (loc packed-integer pos) (stream1 loc)) + (do-packed-varints (loc packed-integer pos) (stream2 loc)) + (do-packed-varints (loc packed-integer pos) (stream3 loc))) + (values (stream1) (stream2) (stream3)))) (define-symbol-macro lz-symbol-1 210) ; arbitrary value that isn't frequent in the input (define-symbol-macro lz-symbol-2 218) ; ditto diff -Nru sbcl-2.1.1/src/code/defmacro.lisp sbcl-2.1.11/src/code/defmacro.lisp --- sbcl-2.1.1/src/code/defmacro.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/defmacro.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,7 +9,45 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. -(in-package "SB-IMPL") +(in-package "SB-C") + +(defun macro-function (symbol &optional env) + "If SYMBOL names a macro in ENV, returns the expansion function, +else returns NIL. If ENV is unspecified or NIL, use the global environment +only." + ;; local function definitions (ordinary) can shadow a global macro + (typecase env + #+(and sb-fasteval (not sb-xc-host)) + (sb-interpreter:basic-env + (multiple-value-bind (kind def) + (sb-interpreter:find-lexical-fun env symbol) + (when def + (return-from macro-function (when (eq kind :macro) def))))) + (lexenv + (let ((def (cdr (assoc symbol (lexenv-funs env))))) + (when def + (return-from macro-function + (when (typep def '(cons (eql macro))) (cdr def))))))) + (values (info :function :macro-function symbol))) + +(defun (setf macro-function) (function symbol &optional environment) + (declare (symbol symbol) (type function function)) + (when environment + ;; Note: Technically there could be an ENV optional argument to SETF + ;; MACRO-FUNCTION, but since ANSI says that the consequences of + ;; supplying a non-nil one are undefined, we don't allow it. + ;; (Thus our implementation of this unspecified behavior is to + ;; complain. SInce the behavior is unspecified, this is conforming.:-) + (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S" + symbol environment)) + (when (eq (info :function :kind symbol) :special-form) + (error "~S names a special form." symbol)) + (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S") + (clear-info :function :type symbol) + (setf (info :function :kind symbol) :macro) + (setf (info :function :macro-function symbol) function) + #-sb-xc-host (install-guard-function symbol `(:macro ,symbol))) + function) (let () (defmacro sb-xc:defmacro (name lambda-list &body body) @@ -27,17 +65,40 @@ name)) ;; The name of the lambda is (MACRO-FUNCTION name) ;; which does not conflict with any legal function name. - (let ((def (make-macro-lambda (sb-c::debug-name 'macro-function name) + (let ((def (make-macro-lambda (debug-name 'macro-function name) lambda-list body 'defmacro name))) `(progn ;; %COMPILER-DEFMACRO just performs a check for duplicate definitions ;; within a file. (eval-when (:compile-toplevel) - (sb-c::%compiler-defmacro :macro-function ',name)) + (%compiler-defmacro :macro-function ',name)) (eval-when (:compile-toplevel :load-toplevel :execute) - (sb-c::%defmacro ',name ,def (sb-c:source-location))))))) + (%defmacro ',name ,def (source-location))))))) + +;;; Detect duplicate definitions within a file. However, no package +;;; lock check is necessary - it's handled elsewhere. +;;; +;;; Additionally, this is a STYLE-WARNING, not a WARNING, because there is +;;; meaningful behavior that can be ascribed to some redefinitions, e.g. +;;; (defmacro foo () first-definition) +;;; (defun f () (use-it (foo ))) +;;; (defmacro foo () other-definition) +;;; will use the first definition when compiling F, but make the second available +;;; in the loaded fasl. In this usage it would have made sense to wrap the +;;; respective definitions with EVAL-WHEN for different situations, +;;; but as long as the compile-time behavior is deterministic, it's just bad style +;;; and not flat-out wrong, though there is indeed some waste in the fasl. +;;; +;;; KIND is the globaldb KIND of this NAME +(defun %compiler-defmacro (kind name) + (let ((name-key `(,kind ,name))) + (when (boundp '*lexenv*) + ;; a slight OAOO issue here wrt %COMPILER-DEFUN + (if (member name-key (fun-names-in-this-file *compilation*) :test #'equal) + (compiler-style-warn 'same-file-redefinition-warning :name name) + (push name-key (fun-names-in-this-file *compilation*)))))) -(defun sb-c::%defmacro (name definition source-location) +(defun %defmacro (name definition source-location) (declare (ignorable source-location)) ; xc-host doesn't use ;; old note (ca. 1985, maybe:-): "Eventually %%DEFMACRO ;; should deal with clearing old compiler information for @@ -64,30 +125,3 @@ :new-function definition :new-location source-location)) (setf (macro-function name) definition))) name) - -#+sb-xc-host -(let ((real-expander (cl:macro-function 'sb-xc:defmacro))) - ;; Inform the cross-compiler how to expand SB-XC:DEFMACRO (= DEFMACRO). - (setf (macro-function 'sb-xc:defmacro) - (lambda (form env) - (declare (ignore env)) - ;; Since SB-KERNEL:LEXENV isn't compatible with the host, - ;; just pass NIL. The expansion correctly captures a non-null - ;; environment, but the expander doesn't need it. - (funcall real-expander form nil))) - ;; Building the cross-compiler should skip the compile-time-too - ;; processing SB-XC:DEFMACRO. - (setf (cl:macro-function 'sb-xc:defmacro) - (lambda (form env) `(let () ,(funcall real-expander form env))))) - -#+sb-xc-host -(progn - (setf (macro-function 'named-ds-bind) - (lambda (form env) (declare (ignore env)) (cl:macroexpand-1 form nil))) - - ;; SB-XC:DEFMACRO's expansion uses NAMED-DS-BIND which expands to - ;; BINDING* (from "early-extensions") that hand-written code also - ;; wants to use. So expand it in the target by using the host's - ;; expander until it gets seen again during make-host-2. - (setf (macro-function 'binding*) - (lambda (form env) (declare (ignore env)) (cl:macroexpand-1 form nil)))) diff -Nru sbcl-2.1.1/src/code/defsetfs.lisp sbcl-2.1.11/src/code/defsetfs.lisp --- sbcl-2.1.1/src/code/defsetfs.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/defsetfs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -24,34 +24,41 @@ (defsetf context-register %set-context-register) (defsetf boxed-context-register %set-boxed-context-register) (defsetf context-float-register %set-context-float-register) -;;; from bit-bash.lisp -(defsetf word-sap-ref %set-word-sap-ref) -;;; from debug-int.lisp -(in-package "SB-DI") -(defsetf stack-ref %set-stack-ref) -(defsetf debug-var-value %set-debug-var-value) -(defsetf breakpoint-info %set-breakpoint-info) +#-x86-64 +(progn + (declaim (inline assign-vector-flags logior-header-bits reset-header-bits)) + (defun assign-vector-flags (vector flags) + (set-header-data vector (dpb flags (byte 8 #.array-flags-data-position) (get-header-data vector))) + (values)) + (defun logior-header-bits (object bits) + (set-header-data object (logior (get-header-data object) bits)) + object) + (defun reset-header-bits (object bits) + (set-header-data object (logand (get-header-data object) (lognot bits))) + (values))) + +(defmacro logior-array-flags (array flags) + `(logior-header-bits ,array (ash ,flags #.array-flags-data-position))) +(defmacro reset-array-flags (array flags) + `(reset-header-bits ,array (ash ,flags #.array-flags-data-position))) -;;; from bignum.lisp (in-package "SB-IMPL") -(defsetf %bignum-ref %bignum-set) -;;; from defstruct.lisp -(defsetf %instance-ref %instance-set) - -(defsetf %raw-instance-ref/word %raw-instance-set/word) -(defsetf %raw-instance-ref/signed-word %raw-instance-set/signed-word) -(defsetf %raw-instance-ref/single %raw-instance-set/single) -(defsetf %raw-instance-ref/double %raw-instance-set/double) -(defsetf %raw-instance-ref/complex-single %raw-instance-set/complex-single) -(defsetf %raw-instance-ref/complex-double %raw-instance-set/complex-double) - -(defsetf %instance-layout %set-instance-layout) -(defsetf %funcallable-instance-info %set-funcallable-instance-info) -;;; The writer is named after the reader, but only operates on FUNCALLABLE-INSTANCE -;;; even if the reader operates on any FUNCTION. -(defsetf %fun-layout %set-funcallable-instance-layout) +(declaim (inline (setf %funcallable-instance-info))) +;;; Funcallable instances are just like closures, but there's another slot or two +;;; depending on whether the layout pointer is in a slot or in the header word. +(defun (setf %funcallable-instance-info) (newval fin index) + (%closure-index-set fin (+ index (- sb-vm:funcallable-instance-info-offset + sb-vm:closure-info-offset)) + newval) + newval) +;;; This is just to keep the DEFSTRUCT logic consistent with %INSTANCE-SET, +;;; but the canonical setter is the function named (setf %funcallable-instance-info) +(declaim (inline %set-funcallable-instance-info)) +(defun %set-funcallable-instance-info (fin index newval) + (funcall #'(setf %funcallable-instance-info) newval fin index) + (values)) ;;; from early-setf.lisp @@ -154,27 +161,13 @@ (defsetf svref %svset) (defsetf char %charset) (defsetf schar %scharset) -(defsetf %array-dimension %set-array-dimension) -(defsetf %vector-raw-bits %set-vector-raw-bits) +(declaim (inline (setf %vector-raw-bits))) +(defun (setf %vector-raw-bits) (bits vector index) + (%set-vector-raw-bits vector index bits) + bits) (defsetf symbol-value set) (defsetf symbol-global-value set-symbol-global-value) -(defsetf symbol-plist %set-symbol-plist) (defsetf fill-pointer %set-fill-pointer) -(defsetf sap-ref-8 %set-sap-ref-8) -(defsetf signed-sap-ref-8 %set-signed-sap-ref-8) -(defsetf sap-ref-16 %set-sap-ref-16) -(defsetf signed-sap-ref-16 %set-signed-sap-ref-16) -(defsetf sap-ref-32 %set-sap-ref-32) -(defsetf signed-sap-ref-32 %set-signed-sap-ref-32) -(defsetf sap-ref-64 %set-sap-ref-64) -(defsetf signed-sap-ref-64 %set-signed-sap-ref-64) -(defsetf sap-ref-word %set-sap-ref-word) -(defsetf signed-sap-ref-word %set-signed-sap-ref-word) -(defsetf sap-ref-sap %set-sap-ref-sap) -(defsetf sap-ref-lispobj %set-sap-ref-lispobj) -(defsetf sap-ref-single %set-sap-ref-single) -(defsetf sap-ref-double %set-sap-ref-double) -#+long-float (defsetf sap-ref-long %set-sap-ref-long) (defsetf subseq (sequence start &optional end) (v) `(progn (replace ,sequence ,v :start1 ,start :end1 ,end) ,v)) @@ -182,7 +175,12 @@ (defsetf fdefinition %set-fdefinition) ;;; from kernel.lisp -(defsetf code-header-ref code-header-set) +#-darwin-jit +(progn +(declaim (inline (setf code-header-ref))) +(defun (setf code-header-ref) (value code index) + (code-header-set code index value) + value)) ;;; from pcl (defsetf slot-value sb-pcl::set-slot-value) @@ -335,18 +333,19 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (%defsetf 'truly-the (info :setf :expander 'the)) (%defsetf 'the* (info :setf :expander 'the)) - - (%defsetf 'mask-field (info :setf :expander 'ldb) - "The first argument is a byte specifier. The second is any place form + (%defsetf 'mask-field + (lambda (&rest args) + "The first argument is a byte specifier. The second is any place form acceptable to SETF. Replaces the specified byte of the number in this place -with bits from the corresponding position in the new value.") +with bits from the corresponding position in the new value." + (apply (info :setf :expander 'ldb) args))) ;;; SETF of LOGBITP is not mandated by CLHS but is nice to have. ;;; FIXME: the code is suboptimal. Better code would "pre-shift" the 1 bit, ;;; so that result = (in & ~mask) | (flag ? mask : 0) ;;; Additionally (setf (logbitp N x) t) is extremely stupid- it first clears ;;; and then sets the bit, though it does manage to pre-shift the constants. - (%defsetf 'logbitp (info :setf :expander 'ldb)))) + (%defsetf 'logbitp (info :setf :expander 'ldb)))) ;;; Rather than have a bunch of SB-PCL::FAST-METHOD function names all point ;;; to one that is randomly chosen - and therefore looks confusing - diff -Nru sbcl-2.1.1/src/code/defstruct.lisp sbcl-2.1.11/src/code/defstruct.lisp --- sbcl-2.1.1/src/code/defstruct.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/defstruct.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -22,7 +22,7 @@ (let ((res (info :type :compiler-layout name))) (cond ((not res) (error "Class is not yet defined or was undefined: ~S" name)) - ((not (typep (layout-info res) 'defstruct-description)) + ((not (typep (wrapper-%info res) 'defstruct-description)) (error "Class is not a structure class: ~S" name)) (t (check-deprecated-type name) @@ -30,7 +30,7 @@ (defun compiler-layout-ready-p (name) (let ((layout (info :type :compiler-layout name))) - (and layout (typep (layout-info layout) 'defstruct-description)))) + (and layout (typep (wrapper-%info layout) 'defstruct-description)))) (sb-xc:defmacro %make-structure-instance-macro (dd slot-specs &rest slot-vars) (if (compiler-layout-ready-p (dd-name dd)) @@ -59,53 +59,11 @@ (defun %make-funcallable-structure-instance-allocator (dd slot-specs) (when slot-specs (bug "funcallable-structure-instance allocation with slots unimplemented")) - (let ((name (dd-name dd)) - (length (dd-length dd)) - (nobject (gensym "OBJECT"))) - (values + (values (compile nil `(lambda () - (let ((,nobject (%make-funcallable-instance ,length))) - (setf (%fun-layout ,nobject) - (%delayed-get-compiler-layout ,name)) - ,nobject)))))) - -;;; Delay looking for compiler-layout until the constructor is being -;;; compiled, since it doesn't exist until after the EVAL-WHEN -;;; (COMPILE) stuff is compiled. (Or, in the oddball case when -;;; DEFSTRUCT is executing in a non-toplevel context, the -;;; compiler-layout still doesn't exist at compilation time, and we -;;; delay still further.) -(sb-xc:defmacro %delayed-get-compiler-layout (name) - (let ((layout (info :type :compiler-layout name))) - (cond (layout - ;; ordinary case: When the DEFSTRUCT is at top level, - ;; then EVAL-WHEN (COMPILE) stuff will have set up the - ;; layout for us to use. - (unless (typep (layout-info layout) 'defstruct-description) - (error "Class is not a structure class: ~S" name)) - `,layout) - (t - ;; KLUDGE: In the case that DEFSTRUCT is not at top-level - ;; the layout doesn't exist at compile time. In that case - ;; we laboriously look it up at run time. This code will - ;; run on every constructor call and will likely be quite - ;; slow, so if anyone cares about performance of - ;; non-toplevel DEFSTRUCTs, it should be rewritten to be - ;; cleverer. -- WHN 2002-10-23 - (sb-c:compiler-notify - "implementation limitation: ~ - Non-toplevel DEFSTRUCT constructors are slow.") - (with-unique-names (layout) - `(let ((,layout (info :type :compiler-layout ',name))) - (unless (typep (layout-info ,layout) 'defstruct-description) - (error "Class is not a structure class: ~S" ',name)) - ,layout)))))) - -;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above.. -;;; -;;; FIXME: Perhaps both should be defined with SB-XC:DEFMACRO? -;;; FIXME: Do we really need both? If so, their names and implementations -;;; should probably be tweaked to be more parallel. + (let ((object (%make-funcallable-instance ,(dd-length dd)))) + (setf (%fun-wrapper object) ,(find-layout (dd-name dd))) + object))))) ;;;; DEFSTRUCT-DESCRIPTION @@ -219,7 +177,7 @@ (acond ((dsd-raw-slot-data dsd) (raw-slot-data-raw-type it)) (t))) (defun dsd-primitive-accessor (dsd &aux (rsd (dsd-raw-slot-data dsd))) - (if rsd (raw-slot-data-accessor-name rsd) '%instance-ref)) + (if rsd (raw-slot-data-reader-name rsd) '%instance-ref)) ;;;; typed (non-class) structures @@ -416,6 +374,9 @@ #+sb-xc-host (progn +;; When compiling and loading the cross-compiler, SB-XC:DEFSTRUCT gets +;; a bootstrap definition from src/code/defbangstruct. +;; The old definition has to be uninstalled to avoid a redefinition warning here. (eval-when (:compile-toplevel :load-toplevel :execute) (fmakunbound 'sb-xc:defstruct)) (defmacro sb-xc:defstruct (name-and-options &rest slot-descriptions) @@ -763,7 +724,7 @@ (let ((super (compiler-layout-or-lose (or (first (dd-include dd)) 'structure-object)))) (concatenate 'simple-vector - (layout-inherits super) (vector super))))) + (wrapper-inherits super) (vector super))))) (proto-classoid (if (dd-class-p dd) ;; The classoid needs a layout whereby to convey inheritance. @@ -772,9 +733,9 @@ ;; It's probably too dangerous to stack-allocate, because references ;; could leak from the type cache machinery. (let* ((classoid (make-structure-classoid :name (dd-name dd))) - (layout (make-temporary-layout (hash-layout-name (dd-name dd)) + (layout (make-temporary-wrapper (hash-layout-name (dd-name dd)) classoid inherits))) - (setf (classoid-layout classoid) layout) + (setf (classoid-wrapper classoid) layout) classoid))) (ancestor-slot-comparator-list)) #+sb-xc-host @@ -919,7 +880,8 @@ (setq ctype *universal-type*)) ; a harmless lie (unless ctype - (let ((context (make-type-context type proto-classoid nil))) + (let ((context (make-type-context type proto-classoid + +type-parse-cache-inhibit+))) (setq ctype (specifier-type type context)))) ; Parse once only (cond (included-slot @@ -1005,7 +967,7 @@ (let* ((type (dd-type dd)) (included-structure (if (dd-class-p dd) - (layout-info (compiler-layout-or-lose included-name)) + (wrapper-info (compiler-layout-or-lose included-name)) (typed-structure-info-or-lose included-name)))) ;; checks on legality @@ -1019,8 +981,8 @@ ;; It's not particularly well-defined to :INCLUDE any of the ;; CMU CL INSTANCE weirdosities like CONDITION or ;; GENERIC-FUNCTION, and it's certainly not ANSI-compliant. - (let* ((included-layout (classoid-layout included-classoid)) - (included-dd (layout-dd included-layout))) + (let* ((included-layout (classoid-wrapper included-classoid)) + (included-dd (wrapper-dd included-layout))) (when (dd-alternate-metaclass included-dd) (error "can't :INCLUDE class ~S (has alternate metaclass)" included-name))))) @@ -1089,7 +1051,7 @@ (super (if include (compiler-layout-or-lose (first include)) - (classoid-layout (find-classoid + (classoid-wrapper (find-classoid (or (first superclass-opt) 'structure-object)))))) (case (dd-name info) @@ -1097,24 +1059,24 @@ ;; STREAM is an abstract class and you can't :include it, ;; so the inheritance has to be hardcoded. (concatenate 'simple-vector - (layout-inherits super) - (vector super (classoid-layout (find-classoid 'stream))))) + (wrapper-inherits super) + (vector super (classoid-wrapper (find-classoid 'stream))))) ((fd-stream) ; Similarly, FILE-STREAM is abstract (concatenate 'simple-vector - (layout-inherits super) + (wrapper-inherits super) (vector super - (classoid-layout (find-classoid 'file-stream))))) + (classoid-wrapper (find-classoid 'file-stream))))) ((sb-impl::string-input-stream ; etc sb-impl::string-output-stream sb-impl::fill-pointer-output-stream) (concatenate 'simple-vector - (layout-inherits super) + (wrapper-inherits super) (vector super - (classoid-layout (find-classoid 'string-stream))))) + (classoid-wrapper (find-classoid 'string-stream))))) (pathname (vector (find-layout 't))) (logical-pathname (vector (find-layout 't) (find-layout 'pathname))) (t (concatenate 'simple-vector - (layout-inherits super) + (wrapper-inherits super) (vector super)))))) ;;; Do miscellaneous (LOAD EVAL) time actions for the structure @@ -1127,17 +1089,17 @@ (multiple-value-bind (classoid layout old-layout) (ensure-structure-class dd inherits "current" "new") (cond ((not old-layout) - (unless (eq (classoid-layout classoid) layout) + (unless (eq (classoid-wrapper classoid) layout) (register-layout layout))) (t (%redefine-defstruct classoid old-layout layout) - (let ((old-dd (layout-info old-layout))) + (let ((old-dd (wrapper-info old-layout))) (when (defstruct-description-p old-dd) (dolist (slot (dd-slots old-dd)) (fmakunbound (dsd-accessor-name slot)) (unless (dsd-read-only slot) (fmakunbound `(setf ,(dsd-accessor-name slot))))))) - (setq layout (classoid-layout classoid)))) + (setq layout (classoid-wrapper classoid)))) ;; Don't want to (setf find-classoid) on a a built-in-classoid (unless (and (built-in-classoid-p classoid) (eq (find-classoid (dd-name dd) nil) classoid)) @@ -1147,42 +1109,33 @@ (setf (classoid-source-location classoid) source-location)))) -;;; Return a form accessing the writable place used for the slot -;;; described by DD and DSD in the INSTANCE (a form). -(defun %accessor-place-form (dd dsd instance) - (let (;; Compute REF even if not using it, as a sanity-check of DD-TYPE. - (ref (ecase (dd-type dd) - (structure '%instance-ref) - (funcallable-structure '%funcallable-instance-info) - (list 'nth) - (vector 'aref))) - (index (dsd-index dsd)) - (rsd (dsd-raw-slot-data dsd))) - (cond (rsd - (list (raw-slot-data-accessor-name rsd) instance index)) - ((eq ref 'nth) - (list ref index instance)) - (t - (list ref instance index))))) - -;;; Return the transform of conceptual FUNCTION one of {:READ,:WRITE,:SETF} +;;; Return the transform of OPERATION which is either :READ or :SETF. ;;; as applied to ARGS, given SLOT-KEY which is a cons of a DD and a DSD. +;;; FUN-OR-MACRO, which is used only for the :SETF operation, +;;; indicates whether the argument order corresponds to +;;; (funcall #'(setf mystruct-myslot) newval s) ; :FUNCTION +;;; versus +;;; (setf (mystruct-myslot s) newval) ; :MACRO ;;; Return NIL on failure. -(defun slot-access-transform (function args slot-key) - (when (consp args) ; need at least one arg - (let* ((dd (car slot-key)) - (dsd (cdr slot-key)) - ;; optimistically compute PLACE before checking length of ARGS - ;; because we expect success, and this unifies the three cases. - ;; :SETF is like an invocation of the SETF macro - newval is - ;; the second arg, but :WRITER is #'(SETF fn) - newval is first. - (place - (%accessor-place-form - dd dsd `(the ,(dd-name dd) - ,(car (if (eq function :write) (cdr args) args))))) - (type-spec (dsd-type dsd))) - (if (eq function :read) - (when (singleton-p args) +(defun slot-access-transform (operation args slot-key &optional (fun-or-macro :macro)) + (binding* ((dd (car slot-key)) + (dsd (cdr slot-key)) + (type-spec (dsd-type dsd)) + (index (dsd-index dsd)) + ((writer reader) + (acond ((dsd-raw-slot-data dsd) + (values (raw-slot-data-writer-name it) (raw-slot-data-reader-name it))) + (t + (ecase (dd-type dd) + (funcallable-structure + (values '%set-funcallable-instance-info '%funcallable-instance-info)) + (structure + (values '%instance-set '%instance-ref))))))) + (ecase operation + (:read + (when (singleton-p args) + (let* ((instance-form `(the ,(dd-name dd) ,(car args))) + (place `(,reader ,instance-form ,index))) ;; There are 4 cases of {safe,unsafe} x {always-boundp,possibly-unbound} ;; If unsafe - which implies TYPE-SPEC other than type T - then we must ;; check the type on each read. Assuming that type-checks reject @@ -1191,28 +1144,37 @@ `(the ,type-spec ,place)) (t (unless (dsd-always-boundp dsd) - (setf place `(the* ((not (satisfies sb-vm::unbound-marker-p)) - :context (:struct-read ,(dd-name dd) . ,(dsd-name dsd))) - ,place))) - (if (eq type-spec t) place `(the* (,type-spec :derive-type-only t) ,place))))) - (when (singleton-p (cdr args)) - (let ((inverse (info :setf :expander (car place)))) - (flet ((check (newval) - (if (eq type-spec t) - newval - `(the* (,type-spec :context - (:struct ,(dd-name dd) . ,(dsd-name dsd))) - ,newval)))) - (ecase function - (:setf - ;; Instance setters take newval last, which matches - ;; the order in which a use of SETF has them. - `(,inverse ,@(cdr place) ,(check (second args)))) - (:write - ;; The call to #'(SETF fn) had newval first. - ;; We need to preserve L-to-R evaluation. - (once-only ((new (first args))) - `(,inverse ,@(cdr place) ,(check new)))))))))))) + (setf place + `(the* ((not (satisfies sb-vm::unbound-marker-p)) + :context (:struct-read ,(dd-name dd) . ,(dsd-name dsd))) + ,place))) + (if (eq type-spec t) place + `(the* (,type-spec :derive-type-only t) ,place))))))) + (:setf + ;; The primitive object slot setting vops take newval last, which matches + ;; the order in which a use of SETF has them, but because the vops + ;; do not return anything, we have to bind both arguments. + (when (and (listp args) (singleton-p (cdr args))) + (multiple-value-bind (newval-form instance-form) + (ecase fun-or-macro + (:function (values (first args) (second args))) + (:macro (values (second args) (first args)))) + (if (eq fun-or-macro :function) + ;; This used only for source-transforming (funcall #'(setf myslot) ...). + ;; (SETF x) writer functions have been defined as source-transforms instead of + ;; inline functions, which improved the semantics around clobbering defstruct + ;; writers with random DEFUNs either deliberately or accidentally. + ;; Since users can't define source-transforms (not portably anyway), + ;; we can easily discern which functions were system-generated. + `(let ((#2=#:val + #4=,(if (eq type-spec t) + newval-form + `(the* (,type-spec :context (:struct ,(dd-name dd) . ,(dsd-name dsd))) + ,newval-form))) + (#1=#:instance #3=(the ,(dd-name dd) ,instance-form))) + (,writer #1# ,index #2#) + #2#) + `(let ((#1# #3#) (#2# #4#)) (,writer #1# ,index #2#) #2#)))))))) ;;; Apply TRANSFORM - a special indicator stored in :SOURCE-TRANSFORM ;;; for a DEFSTRUCT copier, accessor, or predicate - to SEXPR. @@ -1233,8 +1195,8 @@ (:predicate `(sb-c::%instance-typep ,arg ',type)) (:copier `(copy-structure (the ,type ,arg))))))) (t - (slot-access-transform (if (consp name) :write :read) - (cdr sexpr) transform))))) + (slot-access-transform (if (consp name) :setf :read) + (cdr sexpr) transform :function))))) (values result (not result)))) ;;; Return a LAMBDA form which can be used to set a slot @@ -1249,7 +1211,7 @@ ;;; the same for subclasses. FIXME: maybe rename UNDEFINE-FUN-NAME to ;;; UNDECLARE-FUNCTION-NAME? (defun undeclare-structure (classoid subclasses-p) - (let ((info (layout-info (classoid-layout classoid)))) + (let ((info (wrapper-%info (classoid-wrapper classoid)))) (when (defstruct-description-p info) (let ((type (dd-name info))) (clear-info :type :compiler-layout type) @@ -1266,39 +1228,20 @@ ;; references are unknown types. (values-specifier-type-cache-clear))) (when subclasses-p - (let ((subclasses (classoid-subclasses classoid))) - (when subclasses - (collect ((subs)) - (dohash ((classoid layout) - subclasses - :locked t) - (declare (ignore layout)) - (undeclare-structure classoid nil) - (subs (classoid-proper-name classoid))) + (collect ((subs)) + (do-subclassoids ((classoid wrapper) classoid) + (declare (ignore wrapper)) + (undeclare-structure classoid nil) + (subs (classoid-proper-name classoid))) ;; Is it really necessary to warn about ;; undeclaring functions for subclasses? - (when (subs) - (warn "undeclaring functions for old subclasses ~ - of ~S:~% ~S" - (classoid-name classoid) - (subs)))))))) + (when (subs) + (warn "undeclaring functions for old subclasses of ~S:~% ~S" + (classoid-name classoid) (subs)))))) ;;; core compile-time setup of any class with a LAYOUT, used even by ;;; !DEFSTRUCT-WITH-ALTERNATE-METACLASS weirdosities -(defun %compiler-set-up-layout (dd - &optional - ;; Several special cases - ;; (STRUCTURE-OBJECT itself, and - ;; structures with alternate - ;; metaclasses) call this function - ;; directly, and they're all at the - ;; base of the instance class - ;; structure, so this is a handy - ;; default. (But note - ;; FUNCALLABLE-STRUCTUREs need - ;; assistance here) - (inherits (vector (find-layout t)))) - +(defun %compiler-set-up-layout (dd inherits) (multiple-value-bind (classoid layout old-layout) (multiple-value-bind (clayout clayout-p) (info :type :compiler-layout (dd-name dd)) @@ -1310,17 +1253,17 @@ "the most recently loaded" :compiler-layout clayout)) (cond (old-layout - (undeclare-structure (layout-classoid old-layout) + (undeclare-structure (wrapper-classoid old-layout) (and (classoid-subclasses classoid) (not (eq layout old-layout)))) - (setf (layout-invalid layout) nil) + (setf (wrapper-invalid layout) nil) ;; FIXME: it might be polite to hold onto old-layout and ;; restore it at the end of the file. -- RMK 2008-09-19 ;; (International Talk Like a Pirate Day). (warn "~@" classoid)) (t - (unless (eq (classoid-layout classoid) layout) + (unless (eq (classoid-wrapper classoid) layout) (register-layout layout :invalidate nil)) ;; Don't want to (setf find-classoid) on a a built-in-classoid (unless (and (built-in-classoid-p classoid) @@ -1400,7 +1343,7 @@ accessor-name (dsd-name dsd)))))))) - (awhen (remove-if-not #'sb-c::emitted-full-call-count fnames) + (awhen (remove-if-not #'sb-impl::emitted-full-call-count fnames) (sb-c:compiler-style-warn 'sb-c:inlining-dependency-failure ;; This message omits the http://en.wikipedia.org/wiki/Serial_comma @@ -1472,16 +1415,17 @@ ;;; both the old and new structure are at the same depthoid. #-sb-xc-host (defun mutable-layout-p (old-layout new-layout) - (if (layout-info old-layout) - (let ((old-bitmap (layout-bitmap old-layout)) - (new-bitmap (layout-bitmap new-layout))) + (declare (type wrapper old-layout new-layout)) + (if (wrapper-info old-layout) + (let ((old-bitmap (wrapper-bitmap old-layout)) + (new-bitmap (wrapper-bitmap new-layout))) ;; The number of extra ID words has to match, as does the number of bitmap ;; words, or else GC will croak when parsing the bitmap. - (and (= (calculate-extra-id-words (layout-depthoid old-layout)) - (calculate-extra-id-words (layout-depthoid new-layout))) - (= (layout-bitmap-words new-layout) - (layout-bitmap-words old-layout)) - (dotimes (i (dd-length (layout-dd old-layout)) t) + (and (= (calculate-extra-id-words (wrapper-depthoid old-layout)) + (calculate-extra-id-words (wrapper-depthoid new-layout))) + (= (bitmap-nwords (wrapper-friend new-layout)) + (bitmap-nwords (wrapper-friend old-layout))) + (dotimes (i (dd-length (wrapper-dd old-layout)) t) (when (and (logbitp i new-bitmap) ; a tagged (i.e. scavenged) slot (not (logbitp i old-bitmap))) ; that was opaque bits (return nil))))) @@ -1493,7 +1437,7 @@ ;;; be used. (defun %redefine-defstruct (classoid old-layout new-layout) (declare (type classoid classoid) - (type layout old-layout new-layout)) + (type wrapper old-layout new-layout)) (declare (ignorable old-layout)) ; for host (let ((name (classoid-proper-name classoid))) (restart-case @@ -1523,7 +1467,7 @@ ;; I hope you know what you're doing..." (register-layout new-layout :invalidate nil - :destruct-layout old-layout)))) + :modify old-layout)))) (values)) ;;; Compute DD's bitmap, storing 1 for each tagged word. @@ -1605,7 +1549,7 @@ (setf rest :untagged)) #-compact-instance-header (when (eq (car (dd-alternate-metaclass dd)) 'function) - ;; There is only one bitmap, which excludes LAYOUT from tagged slots + ;; There is only one possible bitmap, which excludes LAYOUT from tagged slots (return-from calculate-dd-bitmap standard-gf-primitive-obj-layout-bitmap)) ;; Compute two masks with a 1 bit for each dsd-index which contains a descriptor. ;; The "mininal" bitmap contains a 1 for each slot which *must* be scanned in GC, @@ -1638,7 +1582,7 @@ (cond ((eq (dd-name dd) 'sb-lockless::list-node) t) ((dd-include dd) (has-custom-gc-method - (layout-info (compiler-layout-or-lose (car (dd-include dd)))))))) + (wrapper-info (compiler-layout-or-lose (car (dd-include dd)))))))) (aver (eq rest :unspecific)) (return-from calculate-dd-bitmap minimal-bitmap)) @@ -1675,8 +1619,10 @@ ;;; value is true if this is an incompatible redefinition, in which ;;; case it is the old layout. (defun ensure-structure-class (info inherits old-context new-context - &key compiler-layout) + &key compiler-layout + &aux (flags 0)) (declare (type defstruct-description info)) + ;; NB: the variables named "layout" are in fact of type WRAPPER (multiple-value-bind (classoid old-layout) (multiple-value-bind (class constructor) (acond ((cdr (dd-alternate-metaclass info)) @@ -1702,20 +1648,21 @@ fd-stream sb-impl::string-input-stream sb-impl::string-output-stream sb-impl::fill-pointer-output-stream) - (list (layout-classoid (svref inherits (1- (length inherits)))) - (layout-classoid (svref inherits (- (length inherits) 2))))) + (list (wrapper-classoid (svref inherits (1- (length inherits)))) + (wrapper-classoid (svref inherits (- (length inherits) 2))))) (t - (list (layout-classoid + (list (wrapper-classoid (svref inherits (1- (length inherits)))))))) + (unless (dd-alternate-metaclass info) + (setq flags +structure-layout-flag+)) + #-sb-xc-host + (dovector (ancestor inherits) + (setq flags (logior (logand (logior +stream-layout-flag+ + +file-stream-layout-flag+ + +string-stream-layout-flag+) + (wrapper-flags ancestor)) + flags))) (let* ((old-layout (or compiler-layout old-layout)) - (flags - (logior (if (dd-alternate-metaclass info) 0 +structure-layout-flag+) - (if (find #.(find-layout 'stream) inherits) - +stream-layout-flag+ 0) - (if (find #.(find-layout 'file-stream) inherits) - +file-stream-layout-flag+ 0) - (if (find #.(find-layout 'string-stream) inherits) - +string-stream-layout-flag+ 0))) (new-layout (when (or (not old-layout) *type-system-initialized*) (make-layout (hash-layout-name (dd-name info)) @@ -1732,31 +1679,31 @@ ;; The assignment of INFO here can almost be deleted, ;; except for a few magical types that don't d.t.r.t. in cold-init: ;; STRUCTURE-OBJECT, CONDITION, ALIEN-VALUE, INTERPRETED-FUNCTION - (setf (layout-info old-layout) info) + (setf (wrapper-info old-layout) info) (values classoid old-layout nil)) (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING ;; of classic CMU CL. I moved it out to here because it was only ;; exercised in this code path anyway. -- WHN 19990510 - (not (eq (layout-classoid new-layout) (layout-classoid old-layout))) + (not (eq (wrapper-classoid new-layout) (wrapper-classoid old-layout))) (error "shouldn't happen: weird state of OLD-LAYOUT?")) ((warn-if-altered-layout old-context old-layout new-context - (layout-length new-layout) - (layout-inherits new-layout) - (layout-depthoid new-layout) - (layout-bitmap new-layout)) + (wrapper-length new-layout) + (wrapper-inherits new-layout) + (wrapper-depthoid new-layout) + (wrapper-bitmap new-layout)) (values classoid new-layout old-layout)) (t - (let ((old-info (layout-info old-layout))) + (let ((old-info (wrapper-info old-layout))) (if old-info (cond ((redefine-structure-warning classoid old-info info) (values classoid new-layout old-layout)) (t - (setf (layout-info old-layout) info) + (setf (wrapper-info old-layout) info) (values classoid old-layout nil))) (progn - (setf (layout-info old-layout) info) + (setf (wrapper-info old-layout) info) (values classoid old-layout nil))))))))) ;;; Return a list of pairs (name . index). Used for :TYPE'd @@ -1789,24 +1736,11 @@ ;;; ;;; This is split into two functions: ;;; * INSTANCE-CONSTRUCTOR-FORM has to deal with raw slots -;;; (there are two variations on this) ;;; * TYPED-CONSTRUCTOR-FORM deal with LIST & VECTOR ;;; which might have "name" symbols stuck in at various weird places. (defun instance-constructor-form (dd values &aux (dd-slots (dd-slots dd))) - ;; The difference between the two implementations here is that on all - ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which - ;; must be able to deal with immediate values as well -- unlike - ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With - ;; some additional cleverness we might manage without them and just a single - ;; implementation here, though -- figure out a way to ensure that on those - ;; platforms we always still get a non-immediate TN in every case... - ;; - ;; Until someone does that, this means that instances with raw slots can be - ;; DX allocated only on platforms with those additional VOPs. (aver (= (length dd-slots) (length values))) - (if (or #+(or ppc ppc64 x86 x86-64) t) - ;; Have raw-instance-init vops - (collect ((slot-specs) (slot-values)) + (collect ((slot-specs) (slot-values)) (mapc (lambda (dsd value &aux (raw-type (dsd-raw-type dsd)) (spec (list* :slot raw-type (dsd-index dsd)))) (cond ((eq value '.do-not-initialize-slot.) @@ -1818,36 +1752,7 @@ (slot-values value)))) dd-slots values) `(%make-structure-instance-macro ,dd ',(slot-specs) ,@(slot-values))) - ;; Don't have raw-instance-init vops - (collect ((slot-specs) (slot-values) (raw-slots) (raw-values)) - ;; Partition into non-raw and raw - (mapc (lambda (dsd value &aux (raw-type (dsd-raw-type dsd)) - (spec (list* :slot raw-type (dsd-index dsd)))) - (cond ((eq value '.do-not-initialize-slot.) - (when (eq raw-type t) - (rplaca spec :unbound) - (slot-specs spec))) - ((eq raw-type t) - (slot-specs spec) - (slot-values value)) - (t - (raw-slots dsd) - (raw-values value)))) - dd-slots values) - (let ((instance-form - `(%make-structure-instance-macro ,dd - ',(slot-specs) ,@(slot-values)))) - (if (raw-slots) - (let ((temp (make-symbol "INSTANCE"))) - `(let ((,temp ,instance-form)) - ;; Transform to %RAW-INSTANCE-SET/foo, not SETF, - ;; in case any slots are readonly. - ,@(mapcar (lambda (dsd value) - (slot-access-transform - :setf (list temp value) (cons dd dsd))) - (raw-slots) (raw-values)) - ,temp)) - instance-form))))) + ) ;;; A "typed" constructor prefers to use a single call to LIST or VECTOR ;;; if possible, but can't always do that for VECTOR because it might not @@ -2193,44 +2098,38 @@ (declare (symbol constructor)) ; NIL for none (declare (type (member structure funcallable-structure) dd-type)) - (let* ((dd (make-dd-with-alternate-metaclass + (let ((dd (make-dd-with-alternate-metaclass :class-name class-name :slot-names slot-names :superclass-name superclass-name :metaclass-name metaclass-name :metaclass-constructor metaclass-constructor - :dd-type dd-type)) - (delayed-layout-form `(%delayed-get-compiler-layout ,class-name)) - (raw-maker-form - (ecase dd-type - (structure `(%make-structure-instance-macro ,dd nil)) - (funcallable-structure - `(let ((object - ;; TRULY-THE should not be needed. But it is, to avoid - ;; a type check on the next SETF. Why??? - (truly-the funcallable-instance - (%make-funcallable-instance ,(dd-length dd))))) - (setf (%fun-layout object) ,delayed-layout-form) - object))))) + :dd-type dd-type))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) + (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-defstruct ',dd ',(!inherits-for-structure dd)) (when (eq (info :type :kind ',class-name) :defined) (setf (info :type :kind ',class-name) :instance)) ,@(when (eq metaclass-name 'static-classoid) `((declaim (freeze-type ,class-name))))) - ,@(accessor-definitions dd) - ,@(when constructor - `((defun ,constructor (,@slot-names &aux (object ,raw-maker-form)) + ,@(accessor-definitions dd) + ,@(when constructor + (multiple-value-bind (allocate set-layout) + (ecase dd-type + (structure + (values `(%make-structure-instance-macro ,dd nil) nil)) + (funcallable-structure + (values `(truly-the ,class-name + (%make-funcallable-instance ,(dd-length dd))) + `((macrolet ((the-layout () + (info :type :compiler-layout ',class-name))) + (setf (%fun-wrapper object) (the-layout))))))) + `((defun ,constructor (,@slot-names &aux (object ,allocate)) + ,@set-layout ,@(mapcar (lambda (dsd) `(setf (,(dsd-accessor-name dsd) object) ,(dsd-name dsd))) (dd-slots dd)) - object))) - - ;; Usually we AVER instead of ASSERT, but AVER isn't defined yet. - ;; A naive reading of 'build-order' suggests it is, - ;; but due to def!struct delay voodoo, it isn't. - (assert (null (symbol-value '*defstruct-hooks*)))))) + object))))))) ;;;; finalizing bootstrapping @@ -2243,17 +2142,13 @@ ;;; instead of trying to generalize the ordinary DEFSTRUCT code. (defun !set-up-structure-object-class () (let ((dd (make-defstruct-description t 'structure-object))) - (setf - (dd-slots dd) nil - (dd-length dd) sb-vm:instance-data-start - (dd-type dd) 'structure) - (%compiler-set-up-layout dd))) + (setf (dd-length dd) sb-vm:instance-data-start) + (%compiler-set-up-layout dd (vector (find-layout 't))))) #+sb-xc-host(!set-up-structure-object-class) (defun find-defstruct-description (name &optional (errorp t)) (let* ((classoid (find-classoid name errorp)) - (info (and classoid - (layout-info (classoid-layout classoid))))) + (info (and classoid (wrapper-%info (classoid-wrapper classoid))))) (cond ((defstruct-description-p info) info) (errorp @@ -2270,50 +2165,18 @@ (when (typep ctor '(cons t (eql :default))) (car ctor)))) -;;; These functions are required to emulate SBCL kernel functions -;;; in a vanilla ANSI Common Lisp cross-compilation host. -;;; The emulation doesn't need to be efficient, since it's needed -;;; only for object dumping. #+sb-xc-host -(progn - ;; The set of structure types that we access by slot position at cross-compile - ;; time is fairly small, including these and nothing but these: - ;; - DEFINITION-SOURCE-LOCATION - ;; - DEFSTRUCT-DESCRIPTION, DEFSTRUCT-SLOT-DESCRIPTION - ;; - DEBUG-SOURCE, COMPILED-DEBUG-INFO, COMPILED-DEBUG-FUN-{something} - ;; - HEAP-ALIEN-INFO and ALIEN-{something}-TYPE - ;; - COMMA - (defun %instance-layout (instance) - (classoid-layout (find-classoid (type-of instance)))) - (defun %instance-length (instance) - ;; In the target, it is theoretically possible to have %INSTANCE-LENGTH - ;; exceeed layout length, but in the cross-compiler they're the same. - (layout-length (%instance-layout instance))) - (defun %instance-ref (instance index) - (let* ((layout (%instance-layout instance)) - (map (layout-index->accessor-map layout))) - (when (zerop (length map)) ; construct it on demand - (let ((slots (dd-slots (layout-info layout)))) - (setf map (make-array (1+ (reduce #'max slots :key #'dsd-index)) - :initial-element nil) - (layout-index->accessor-map layout) map) - (dolist (dsd slots) - (setf (aref map (dsd-index dsd)) (dsd-accessor-name dsd))))) - (funcall (aref map index) instance))) - - (defun %raw-instance-ref/word (instance index) - (declare (ignore instance index)) - (error "No such thing as raw structure access on the host")) - - ;; Setting with (FUNCALL `(SETF ,accessor) ...) is unportable because - ;; "The mechanism by which defstruct arranges for slot accessors to be - ;; usable with setf is implementation-dependent; for example, it may - ;; use setf functions, setf expanders, or some other - ;; implementation-dependent mechanism ..." - ;; But such capability seems not to be needed. - (defun %instance-set (instance index new-value) - (declare (ignore instance index new-value)) - (error "Can not use %INSTANCE-SET on cross-compilation host."))) +(defun %instance-ref (instance index) + (let* ((wrapper (%instance-wrapper instance)) + (map (wrapper-index->accessor-map wrapper))) + (when (zerop (length map)) ; construct it on demand + (let ((slots (dd-slots (wrapper-%info wrapper)))) + (setf map (make-array (1+ (reduce #'max slots :key #'dsd-index)) + :initial-element nil) + (wrapper-index->accessor-map wrapper) map) + (dolist (dsd slots) + (setf (aref map (dsd-index dsd)) (dsd-accessor-name dsd))))) + (funcall (aref map index) instance))) ;;; It's easier for the compiler to recognize the output of M-L-F-S-S ;;; without extraneous QUOTE forms, so we define some trivial wrapper macros. @@ -2322,15 +2185,6 @@ (defmacro sb-pcl::set-slots (instance name-list &rest values) `(sb-pcl::%set-slots ,instance ',name-list ,@values)) -#-sb-xc-host -(defun allocate-struct (type) - (let* ((layout (classoid-layout (the structure-classoid (find-classoid type)))) - (structure (%make-instance (layout-length layout)))) - (setf (%instance-layout structure) layout) - (dolist (dsd (dd-slots (layout-dd layout)) structure) - (when (eq (dsd-raw-type dsd) 't) - (setf (%instance-ref structure (dsd-index dsd)) (make-unbound-marker)))))) - ;;; We require that MAKE-LOAD-FORM-SAVING-SLOTS produce deterministic output ;;; and that its output take a particular recognizable form so that it can ;;; be optimized into a sequence of fasl ops. @@ -2367,7 +2221,7 @@ (val (funcall acc object ind))) (list `(,acc ,object ,ind) (if (quote-p val) `',val val))))) - (dd-slots (layout-dd (%instance-layout object)))))) + (dd-slots (wrapper-dd (%instance-wrapper object)))))) #-sb-xc-host (values `(,(if (symbolp type) 'new-instance 'allocate-instance) ,type) (loop for slot in (sb-mop:class-slots (class-of object)) @@ -2410,7 +2264,7 @@ (pop inits) (return nil))))) (multiple-value-bind (creation-form init-form) - (handler-case (sb-xc:make-load-form constant (make-null-lexenv)) + (handler-case (make-load-form constant (make-null-lexenv)) (error (condition) (sb-c:compiler-error condition))) (cond ((and (listp creation-form) (typep constant 'structure-object) @@ -2418,7 +2272,7 @@ (eq (second creation-form) (type-of constant)) (typep init-form '(cons (eql setf))) (canonical-p (cdr init-form) - (dd-slots (layout-dd (%instance-layout constant))) + (dd-slots (wrapper-dd (%instance-wrapper constant))) constant)) (values nil 'sb-fasl::fop-struct)) (t diff -Nru sbcl-2.1.1/src/code/deftypes-for-target.lisp sbcl-2.1.11/src/code/deftypes-for-target.lisp --- sbcl-2.1.1/src/code/deftypes-for-target.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/deftypes-for-target.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -260,4 +260,6 @@ (sb-xc:deftype extended-function-designator () '(satisfies extended-function-designator-p)) +#-metaspace (sb-xc:deftype sb-vm:layout () 'wrapper) + (/show0 "deftypes-for-target.lisp end of file") diff -Nru sbcl-2.1.1/src/code/describe.lisp sbcl-2.1.11/src/code/describe.lisp --- sbcl-2.1.1/src/code/describe.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/describe.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -539,13 +539,15 @@ (let ((*print-circle* nil) (*print-level* 24) (*print-length* 100)) - (format stream "~@:_Lambda-list: ~:S" lambda-list))) + (format stream "~@:_Lambda-list: ~/sb-impl:print-lambda-list/" lambda-list))) (defun describe-argument-precedence-order (argument-list stream) (let ((*print-circle* nil) (*print-level* 24) (*print-length* 100)) - (format stream "~@:_Argument precedence order: ~:A" argument-list))) + (format stream "~@:_Argument precedence order: ~ + ~/sb-impl:print-lambda-list/" + argument-list))) (defun describe-function-source (function stream) (declare (function function)) @@ -599,7 +601,7 @@ (t (let* ((fun (or function (fdefinition name))) (derived-type (and function - (%fun-type function))) + (%fun-ftype function))) (legal-name-p (legal-fun-name-p name)) (ctype (and legal-name-p (global-ftype name))) @@ -614,7 +616,7 @@ (member from '(:defined-method :defined))) (setf derived-type type))) (unless derived-type - (setf derived-type (%fun-type fun))) + (setf derived-type (%fun-ftype fun))) (if (typep fun 'standard-generic-function) (values fun "a generic function" @@ -683,7 +685,8 @@ (format stream "Methods:") (dolist (method methods) (pprint-indent :block 2 stream) - (format stream "~@:_(~A ~{~S ~}~:S)" + (format stream "~@:_(~A ~{~S ~}~ + ~/sb-impl:print-lambda-list/)" name (method-qualifiers method) (sb-pcl::unparse-specializers @@ -696,12 +699,14 @@ (describe-block (stream "~A has a compiler-macro:" name) (describe-documentation it t stream) (describe-function-source it stream))) + ;; It seems entirely bogus to claim that, for example (SETF CAR) + ;; has a setf expander when what we mean is that CAR has. (when (and (consp name) (eq 'setf (car name)) (not (cddr name))) (let* ((name2 (second name)) (expander (info :setf :expander name2))) - (cond ((typep expander '(and symbol (not null))) + (cond ((typep expander '(cons symbol)) (describe-block (stream "~A has setf-expansion: ~S" - name expander) + name (car expander)) (describe-documentation name2 'setf stream))) (expander (when (listp expander) diff -Nru sbcl-2.1.1/src/code/early-array.lisp sbcl-2.1.11/src/code/early-array.lisp --- sbcl-2.1.1/src/code/early-array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-array.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-IMPL") - -;;; The ANSI-specified minimum is 8. -(defconstant array-rank-limit 256 - "the exclusive upper bound on the rank of an array") - -;;; - 2 to leave space for the array header -(defconstant array-dimension-limit (- most-positive-fixnum 2) - "the exclusive upper bound on any given dimension of an array") - -(defconstant array-total-size-limit (- most-positive-fixnum 2) - "the exclusive upper bound on the total number of elements in an array") diff -Nru sbcl-2.1.1/src/code/early-class.lisp sbcl-2.1.11/src/code/early-class.lisp --- sbcl-2.1.1/src/code/early-class.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-class.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,123 +0,0 @@ -;;;; Early support routines for class-related things (including conditions). - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-KERNEL") - -(defun call-with-defining-class (kind name thunk) - (declare (ignorable kind name)) - (with-single-package-locked-error - (:symbol name "defining ~S as a ~(~A~)" kind) - (funcall thunk))) - -(defun preinform-compiler-about-class-type (name forthcoming-info) - ;; Unless the type system already has an actual type attached to - ;; NAME (in which case (1) writing a placeholder value over that - ;; actual type as a compile-time side-effect would probably be a bad - ;; idea and (2) anyway we don't need to modify it in order to make - ;; NAME be recognized as a valid type name) - (when (and forthcoming-info (not (info :type :kind name))) - ;; Tell the compiler to expect a class with the given NAME, by - ;; writing a kind of minimal placeholder type information. This - ;; placeholder will be overwritten later when the class is - ;; defined. - (setf (info :type :kind name) :forthcoming-defclass-type))) - -(symbol-macrolet - ((reader-function-type (specifier-type '(function (t) t))) - (writer-function-type (specifier-type '(function (t t) t)))) - (flet ((proclaim-ftype-for-name (kind name type) - (ecase kind - (condition - (sb-xc:proclaim `(ftype ,(type-specifier type) ,name))) - (class - (when (eq (info :function :where-from name) :assumed) - (sb-c:proclaim-ftype name type nil :defined)))))) - - (defun preinform-compiler-about-accessors (kind readers writers) - (flet ((inform (names type) - (mapc (lambda (name) (proclaim-ftype-for-name kind name type)) - names))) - (inform readers reader-function-type) - (inform writers writer-function-type))) - - (defun preinform-compiler-about-slot-functions (kind slots) - (flet ((inform (slots key type) - (mapc (lambda (slot) - (let ((name (funcall key slot))) - (proclaim-ftype-for-name kind name type))) - slots))) - (inform slots #'sb-pcl::slot-reader-name reader-function-type) - (inform slots #'sb-pcl::slot-boundp-name reader-function-type) - (inform slots #'sb-pcl::slot-writer-name writer-function-type))))) - -(defun %%compiler-defclass (name readers writers slots) - ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it - ;; "appears as a top level form, the compiler must make the class - ;; name be recognized as a valid type name in subsequent - ;; declarations (as for deftype) and be recognized as a valid class - ;; name for defmethod parameter specializers and for use as the - ;; :metaclass option of a subsequent defclass." - (preinform-compiler-about-class-type name t) - (preinform-compiler-about-accessors 'class readers writers) - (preinform-compiler-about-slot-functions 'class slots)) - -(defun %compiler-defclass (name readers writers slots) - (call-with-defining-class - 'class name - (lambda () - (%%compiler-defclass name readers writers slots)))) - -;;; This used to be in an (EVAL-WHEN (:COMPILE-TOPLEVEL ...)) -;;; which no longer works, because at run-the-xc-time the -;;; WITH-SINGLE-PACKAGE-LOCKED-ERROR macro doesn't work yet, -;;; so just use the definition that was loaded from the fasl -;;; when the cross-compiler was compiled. -(defun %%compiler-define-condition (name direct-supers layout readers writers) - (declare (notinline find-classoid)) - (preinform-compiler-about-class-type name nil) - (preinform-compiler-about-accessors 'condition readers writers) - (multiple-value-bind (class old-layout) - (insured-find-classoid name - #'condition-classoid-p - #'make-condition-classoid) - (setf (layout-classoid layout) class) - (setf (classoid-direct-superclasses class) - (mapcar #'find-classoid direct-supers)) - (cond ((not old-layout) - (register-layout layout)) - ((not *type-system-initialized*) - (setf (layout-classoid old-layout) class) - (setq layout old-layout) - (unless (eq (classoid-layout class) layout) - (register-layout layout))) - ((warn-if-altered-layout "current" - old-layout - "new" - (layout-length layout) - (layout-inherits layout) - (layout-depthoid layout) - (layout-bitmap layout)) - (register-layout layout :invalidate t)) - ((not (classoid-layout class)) - (register-layout layout))) - - (setf (find-classoid name) class) - - ;; Initialize CPL slot. - (setf (condition-classoid-cpl class) - (remove-if-not #'condition-classoid-p - (std-compute-class-precedence-list class))))) - -(defun %compiler-define-condition (name direct-supers layout readers writers) - (call-with-defining-class - 'condition name - (lambda () - (%%compiler-define-condition name direct-supers layout readers writers)))) diff -Nru sbcl-2.1.1/src/code/early-classoid.lisp sbcl-2.1.11/src/code/early-classoid.lisp --- sbcl-2.1.1/src/code/early-classoid.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-classoid.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -17,7 +17,7 @@ ;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information ;;; about a structure type. -;;; It is defined prior to LAYOUT because a LAYOUT-INFO slot +;;; It is defined prior to WRAPPER because WRAPPER-INFO ;;; is declared to hold a DEFSTRUCT-DESCRIPTION. (def!struct (defstruct-description (:conc-name dd-) @@ -94,14 +94,25 @@ ;;; Careful here: if you add more bits, then adjust the bit packing for ;;; 64-bit layouts which also store LENGTH + DEPTHOID in the same word. -(defconstant +structure-layout-flag+ #b00000001) -(defconstant +pathname-layout-flag+ #b00000010) -(defconstant +pcl-object-layout-flag+ #b00000100) -(defconstant +condition-layout-flag+ #b00001000) -(defconstant +simple-stream-layout-flag+ #b00010000) -(defconstant +file-stream-layout-flag+ #b00100000) -(defconstant +string-stream-layout-flag+ #b01000000) -(defconstant +stream-layout-flag+ #b10000000) +(defconstant +structure-layout-flag+ #b000000001) +(defconstant +pathname-layout-flag+ #b000000010) +(defconstant +pcl-object-layout-flag+ #b000000100) +(defconstant +condition-layout-flag+ #b000001000) +(defconstant +simple-stream-layout-flag+ #b000010000) +(defconstant +file-stream-layout-flag+ #b000100000) +(defconstant +string-stream-layout-flag+ #b001000000) +(defconstant +stream-layout-flag+ #b010000000) +(defconstant +sequence-layout-flag+ #b100000000) +(defconstant layout-flags-mask #xffff) ; "strictly flags" bits from the packed field + +;;; the type of LAYOUT-DEPTHOID and LAYOUT-LENGTH values. +;;; Each occupies two bytes of the %BITS slot when possible, +;;; otherwise a slot unto itself. +(def!type layout-depthoid () '(integer -1 #x7FFF)) +(def!type layout-length () '(integer 0 #xFFFF)) +(def!type layout-bitmap () 'integer) +;;; ID must be an fixnum for either value of n-word-bits. +(def!type layout-id () '(signed-byte 30)) ;;; The LAYOUT structure is pointed to by the first cell of instance ;;; (or structure) objects. It represents what we need to know for @@ -138,9 +149,11 @@ ;;; 32-bit is not done yet. Three slots are still used, instead of two. -(sb-xc:defstruct (layout (:copier nil) +#-metaspace +(progn +(sb-xc:defstruct (wrapper (:copier nil) ;; Parsing DEFSTRUCT uses a temporary layout - (:constructor make-temporary-layout + (:constructor make-temporary-wrapper (clos-hash classoid inherits &aux (invalid nil)))) ;; A packed field containing the DEPTHOID, LENGTH, and FLAGS @@ -209,7 +222,44 @@ #-64-bit (id-word3 0 :type word) #-64-bit (id-word4 0 :type word) #-64-bit (id-word5 0 :type word)) -(declaim (freeze-type layout)) +(declaim (freeze-type wrapper))) + +#+metaspace +(progn +;;; Separating the pointer and nonpointer slots of LAYOUT satisfies the +;;; requirement of a certain garbage collector (WIP), but also opens up the +;;; possibility of absorbing at least one of the vectorish slots into the +;;; WRAPPER since it could be reallocated with variable size. +;;; The SLOT-TABLE slot might be a good candidate for trailing tagged slots. +(sb-xc:defstruct (wrapper (:copier nil) (:constructor %make-wrapper)) + ;; !!! The FRIEND slot in WRAPPER *MUST* BE FIRST !!! (Wired-in assumption in genesis) + (friend nil :type sb-vm:layout) + (clos-hash (missing-arg) :type (and fixnum unsigned-byte)) ; redundant + (classoid (missing-arg) :type classoid) + (inherits #() :type simple-vector) + (equalp-impl #'equalp-err :type (sfunction (t t) boolean) :read-only t) + (slot-table #(1 nil) :type simple-vector) + (%info nil :type (or list defstruct-description)) + (invalid :uninitialized :type (or cons (member nil t :uninitialized)))) +;;; See #-metaspace structure definition for remarks about each slot. +;;; LAYOUT points to WRAPPER and vice-versa. +;;; The most common LAYOUT is 8 words. +;;; Needing >64 words would be quite unusual - the layout would have +;;; an enormous depthoid or bitmap or both. +(sb-xc:defstruct (sb-vm:layout (:copier nil) + ;; Parsing DEFSTRUCT uses a temporary layout + (:constructor %make-temporary-layout (friend clos-hash))) + ;; !!! The FRIEND slot in LAYOUT *MUST* BE FIRST !!! + (friend nil :type wrapper) + (clos-hash (missing-arg) :type (and fixnum unsigned-byte)) + (flags 0 :type (signed-byte #.sb-vm:n-word-bits)) + (id-word0 0 :type word) + (id-word1 0 :type word) + (id-word2 0 :type word) + ;; There are zero or more raw words if a type needs to store additional layout-ids, + ;; and there are one or more raw words for the GC bitmap. + ) +(declaim (freeze-type wrapper sb-vm:layout))) ;;; The cross-compiler representation of a LAYOUT omits several things: ;;; * BITMAP - obtainable via (DD-BITMAP (LAYOUT-INFO layout)). @@ -219,14 +269,15 @@ ;;; * ID-WORDn are optimizations for TYPEP. ;;; So none of those really make sense on the host. ;;; Also, we eschew the packed representation of length+depthoid+flags. -;;; FLAGS are not even strictly necessary, since they are for optimizing -;;; various type checks. +;;; FLAGS are computed on demand, and not stored. #+sb-xc-host (progn - (defstruct (layout (:include structure!object) - (:constructor host-make-layout - (clos-hash classoid &key id info depthoid inherits - length flags invalid))) + (defstruct (wrapper (:include structure!object) + (:constructor host-make-wrapper + (id clos-hash classoid + &key ((:info %info)) depthoid inherits length invalid + #+metaspace friend))) + #+metaspace (friend) (id nil :type (or null fixnum)) ;; Cross-compiler-only translation from slot index to symbol naming ;; the accessor to call. (Since access by position is not a thing) @@ -237,72 +288,51 @@ ;; But there's no harm in storing it. (clos-hash nil :type (and sb-xc:fixnum unsigned-byte)) (classoid nil :type classoid) - (flags 0 :type word) (invalid :uninitialized :type (or cons (member nil t :uninitialized))) (inherits #() :type simple-vector) (depthoid -1 :type layout-depthoid) (length 0 :type layout-length) - (info nil :type (or null defstruct-description))) - (defun layout-dd (layout) - (the defstruct-description (layout-info layout))) - (defun make-layout (hash classoid &rest keys) - (declare (notinline classoid-name)) ; defined later - (let ((args (copy-list keys)) - (name (classoid-name classoid))) - (remf args :bitmap) - (apply #'host-make-layout - hash classoid - :id (case name - ((t) 1) - (structure-object 2) - (t (cdr (assq name *popular-structure-types*)))) - args))) - (defun make-temporary-layout (clos-hash classoid inherits) - (host-make-layout clos-hash classoid :inherits inherits :invalid nil)) - (defun layout-bitmap (layout) - (if (layout-info layout) (dd-bitmap (layout-info layout)) +layout-all-tagged+))) + (%info nil :type (or null defstruct-description))) + #+metaspace (defstruct (sb-vm:layout (:include structure!object) + (:constructor %make-layout)) + friend) + (defun make-temporary-wrapper (clos-hash classoid inherits) + (host-make-wrapper nil clos-hash classoid :inherits inherits :invalid nil)) + (defun wrapper-flags (wrapper) + (declare (type wrapper wrapper)) + (let ((mapping `((structure-object ,+structure-layout-flag+) + (standard-object ,+pcl-object-layout-flag+) + (pathname ,+pathname-layout-flag+) + (condition ,+condition-layout-flag+) + (file-stream ,+file-stream-layout-flag+) + (string-stream ,+string-stream-layout-flag+) + (stream ,+stream-layout-flag+) + (sequence ,+sequence-layout-flag+))) + (flags 0)) + (dolist (x (cons wrapper (coerce (wrapper-inherits wrapper) 'list)) flags) + (let ((cell (assoc (wrapper-classoid-name x) mapping))) + (when cell (setq flags (logior flags (second cell)))))))) + (defun wrapper-bitmap (wrapper) + (acond ((wrapper-%info wrapper) (dd-bitmap it)) (t +layout-all-tagged+)))) (defun equalp-err (a b) (bug "EQUALP ~S ~S" a b)) +(defmacro name->dd (name) + ;; This wants to be a toplevel macrolet but can't be, because the body of + ;; the macro (which is run in the host) wouldn't see NAME->DD as a macro + ;; when expanding for the target. And it can't be a toplevel FLET because + ;; that would demote the two using macros from toplevel. + `(find-defstruct-description (cond #-metaspace ((eq ,name 'sb-vm:layout) 'wrapper) + (t ,name)))) +(defmacro type-dd-length (type-name) (dd-length (name->dd type-name))) (defmacro get-dsd-index (type-name slot-name) (declare (notinline dsd-index)) ; avoid later inlining failure style-warning - (dsd-index (find slot-name - (dd-slots (find-defstruct-description type-name)) - :key #'dsd-name))) -(defconstant structure-object-layout-id 2) ; KLUDGE -#-sb-xc-host -(defun layout-id (layout) - (let ((depthoid (layout-depthoid layout))) - (truly-the layout-id - (cond ((not (logtest (layout-flags layout) +structure-layout-flag+)) - ;; the 0th word of the ID vector stores the layout id - (layout-id-word0 layout)) - ((>= depthoid 2) - ;; Depthoid 2 is in the 0th index and so on. - (let ((index (- depthoid 2))) - #-64-bit - (%raw-instance-ref/signed-word - layout (+ (get-dsd-index layout id-word0) index)) - #+64-bit ; use SAP-ref for lack of half-sized slots - (with-pinned-objects (layout) - (let ((sap (sap+ (int-sap (get-lisp-obj-address layout)) - (- (ash (+ sb-vm:instance-slots-offset - (get-dsd-index layout id-word0)) - sb-vm:word-shift) - sb-vm:instance-pointer-lowtag)))) - (signed-sap-ref-32 sap (ash index 2)))))) - (t ; KLUDGE: must be STRUCTURE-OBJECT - structure-object-layout-id))))) + (dsd-index (find slot-name (dd-slots (name->dd type-name)) :key #'dsd-name))) ;;; Applicable only if bit-packed (for 64-bit architectures) (defmacro pack-layout-flags (depthoid length flags) - `(logior (ash ,(or depthoid -1) (+ 32 sb-vm:n-fixnum-tag-bits)) - (ash ,(or length 0) 16) - ,(or flags 0))) - -(defmacro type-dd-length (type-name) - (dd-length (find-defstruct-description type-name))) + `(logior (ash ,depthoid (+ 32 sb-vm:n-fixnum-tag-bits)) (ash ,length 16) ,flags)) (defconstant layout-id-vector-fixed-capacity 7) (defmacro calculate-extra-id-words (depthoid) @@ -313,178 +343,68 @@ `(ceiling (max 0 (- ,depthoid ,layout-id-vector-fixed-capacity)) ,(/ sb-vm:n-word-bytes 4))) -(defun set-layout-inherits (layout inherits structurep this-id) - (declare (ignorable structurep this-id)) - (setf (layout-inherits layout) inherits) - ;;; If structurep, and *only* if, store all the inherited layout IDs. - ;;; It looks enticing to try to always store "something", but that goes wrong, - ;;; because only structure-object layouts are growable, and only structure-object - ;;; can store the self-ID in the proper index. - ;;; If the depthoid is -1, the self-ID has to go in index 0. - ;;; Standard-object layouts are not growable. The inherited layouts are known - ;;; only at class finalization time, at which point we've already made the layout. - ;;; Hence, the required indirection to the simple-vector of inherits. - #-sb-xc-host - (cond (structurep - (with-pinned-objects (layout) - (loop with sap = (sap+ (int-sap (get-lisp-obj-address layout)) - (- (ash (+ sb-vm:instance-slots-offset - (get-dsd-index layout id-word0)) - sb-vm:word-shift) - sb-vm:instance-pointer-lowtag)) - for i from 0 by 4 - for j from 2 below (length inherits) - do (setf (signed-sap-ref-32 sap i) (layout-id (svref inherits j))) - finally (setf (signed-sap-ref-32 sap i) this-id)))) - ((not (eql this-id 0)) - (setf (layout-id-word0 layout) this-id)))) - -(defmacro set-bitmap-from-layout (to-layout from-layout) - #+sb-xc-host (declare (ignore to-layout from-layout)) - #-sb-xc-host - `(let ((to-index (+ (type-dd-length layout) - (calculate-extra-id-words (layout-depthoid ,to-layout)))) - (from-index (+ (type-dd-length layout) - (calculate-extra-id-words (layout-depthoid ,from-layout))))) - (dotimes (i (layout-bitmap-words ,from-layout)) - (setf (%raw-instance-ref/word ,to-layout (+ to-index i)) - (%raw-instance-ref/word ,from-layout (+ from-index i)))))) +(declaim (inline wrapper-info wrapper-dd)) +(defun wrapper-info (wrapper) + (let ((info (wrapper-%info wrapper))) (unless (listp info) info))) +(defun (setf wrapper-info) (newval wrapper) + ;; The current value must be nil or a defstruct-description, + ;; otherwise we'd clobber a non-nil slot list. + (aver (not (consp (wrapper-%info wrapper)))) + (setf (wrapper-%info wrapper) newval)) +;; Use WRAPPER-DD to read WRAPPER-INFO and assert that it is non-nil. +(defun wrapper-dd (wrapper) + (the defstruct-description (wrapper-%info wrapper))) ;;; See the pictures above DD-BITMAP in src/code/defstruct for the details. (defconstant standard-gf-primitive-obj-layout-bitmap #+compact-instance-header 6 #-compact-instance-header -4) -;;; For lack of any better to place to write up some detail surrounding -;;; layout creation for structure types, I'm putting here. -;;; When you issue a DEFSTRUCT at the REPL, there are *three* instances -;;; of LAYOUT makde for the new structure. -;;; 1) The first is one associated with a temporary instance of -;;; structure-classoid used in parsing the DEFSTRUCT form so that -;;; we don't signal an UNKNOWN-TYPE condition for something like: -;;; (defstruct chain (next nil :type (or null chain)). -;;; The temporary classoid is garbage immediately after parsing -;;; and is never installed. -;;; 2) The next is the actual LAYOUT that ends up being registered. -;;; 3) The third is a layout created when setting the "compiler layout" -;;; which contains copies of the length/depthoid/inherits etc -;;; that we compare against the installed one to make sure they match. -;;; The third one also gets thrown away. #-sb-xc-host (progn -(declaim (inline layout-dd layout-info layout-slot-list)) -;; Use LAYOUT-DD to read LAYOUT-INFO if you want to assert that it is non-nil. -(defun layout-dd (layout) - (the defstruct-description (layout-%info layout))) -(defun layout-info (layout) - (let ((info (layout-%info layout))) - (if (%instancep info) info))) -(defun layout-slot-list (layout) - (let ((info (layout-%info layout))) - (if (listp info) info))) -(defun (setf layout-info) (newval layout) - ;; The current value must be nil or a defstruct-description, - ;; otherwise we'd clobber a non-nil slot list. - (aver (not (consp (layout-%info layout)))) - (setf (layout-%info layout) newval)) -(defun (setf layout-slot-list) (newval layout) - ;; The current value must be a list, otherwise we'd clobber - ;; a defstruct-description. - (aver (listp (layout-%info layout))) - (setf (layout-%info layout) newval)) - -(define-load-time-global *layout-id-generator* (cons 0 nil)) -(declaim (type (cons fixnum) *layout-id-generator*)) -(defun make-layout (clos-hash classoid - &key (depthoid -1) (length 0) (flags 0) - (inherits #()) - (info nil) - (bitmap (if info (dd-bitmap info) 0)) - (invalid :uninitialized) - &aux (id (or (atomic-pop (cdr *layout-id-generator*)) - (atomic-incf (car *layout-id-generator*))))) - (unless (typep id '(and layout-id (not (eql 0)))) - (error "Layout ID limit reached")) - (let* ((fixed-words (type-dd-length layout)) - (extra-id-words ; count of additional words needed to store ancestors - (if (logtest flags +structure-layout-flag+) - (calculate-extra-id-words depthoid) - 0)) - (bitmap-words (ceiling (1+ (integer-length bitmap)) sb-vm:n-word-bits)) - (nwords (+ fixed-words extra-id-words bitmap-words)) - (layout (truly-the layout - #+immobile-space - (sb-vm::alloc-immobile-fixedobj - (1+ nwords) - (logior (ash nwords sb-vm:instance-length-shift) - sb-vm:instance-widetag)) - #-immobile-space (%make-instance nwords)))) - (setf (%instance-layout layout) #.(find-layout 'layout)) - (setf (layout-flags layout) #+64-bit (pack-layout-flags depthoid length flags) - #-64-bit flags) - (setf (layout-clos-hash layout) clos-hash - (layout-classoid layout) classoid - (layout-invalid layout) invalid) - #-64-bit (setf (layout-depthoid layout) depthoid (layout-length layout) length) - (setf (layout-info layout) info) - (setf (layout-slot-table layout) #(1 nil)) - (set-layout-inherits layout inherits (logtest flags +structure-layout-flag+) id) - (let ((bitmap-base (+ fixed-words extra-id-words))) - (dotimes (i bitmap-words) - (setf (%raw-instance-ref/word layout (+ bitmap-base i)) - (ldb (byte sb-vm:n-word-bits (* i sb-vm:n-word-bits)) bitmap)))) - (setf (layout-invalid layout) invalid) - ;; It's not terribly important that we recycle layout IDs, but I have some other - ;; changes planned that warrant a finalizer per layout. - (unless (built-in-classoid-p classoid) - (finalize layout (lambda () (atomic-push id (cdr *layout-id-generator*))) - :dont-save t)) - layout)) -(declaim (inline layout-bitmap-words)) -(defun layout-bitmap-words (layout) - (declare (layout layout)) - (- (%instance-length layout) (type-dd-length layout))) -(defun layout-bitmap (layout) - (acond ((layout-info layout) (dd-bitmap it)) +(declaim (inline bitmap-nwords bitmap-all-taggedp)) +(defun bitmap-nwords (layout) + (declare (sb-vm:layout layout)) + (- (%instance-length layout) (type-dd-length sb-vm:layout))) + +(defun bitmap-all-taggedp (layout) + ;; All bitmaps have at least 1 word; read that first. + (and (= (%raw-instance-ref/signed-word layout (type-dd-length sb-vm:layout)) + +layout-all-tagged+) + ;; Then check that there are no additional words. + (= (%instance-length layout) (1+ (type-dd-length sb-vm:layout))))) + +#+metaspace ; If metaspace, then WRAPPER has no flags; they're in the LAYOUT. +(defmacro wrapper-flags (x) `(layout-flags (wrapper-friend ,x))) + +;; 32-bit has the depthoid as a slot, 64-bit has it is part of FLAGS which are +;; in the LAYOUT +#+64-bit +(defun wrapper-depthoid (wrapper) (layout-depthoid (wrapper-friend wrapper))) + +(defun wrapper-bitmap (wrapper) + (declare (type wrapper wrapper)) + (acond ((wrapper-info wrapper) (dd-bitmap it)) ;; Instances lacking DD-INFO are CLOS objects, which can't generally have ;; raw slots, except that funcallable-instances may have 2 raw slots - ;; the trampoline and the layout. The trampoline can have a tag, depending ;; on the platform, and the layout is tagged but a special case. ;; In any event, the bitmap is always 1 word, and there are no "extra ID" ;; words preceding it. - (t (%raw-instance-ref/signed-word layout (type-dd-length layout)))))) - -#+(and (not sb-xc-host) 64-bit) -;;; LAYOUT-DEPTHOID gets a vop and a stub -(defmacro layout-length (layout) ; SETFable - `(ldb (byte 16 16) (layout-flags ,layout))) - -(defconstant layout-flags-mask #xffff) ; "strictly flags" bits from the packed field + (t (the fixnum + (%raw-instance-ref/signed-word (wrapper-friend wrapper) + (type-dd-length sb-vm:layout)))))) +#+64-bit +(defmacro wrapper-length (wrapper) ; SETFable + `(ldb (byte 16 16) (layout-flags (wrapper-friend ,wrapper)))) -;;; Abstract out the differences between {32-bit,64-bit} target and XC layouts. -;;; FLAGS can't change once assigned. -(defmacro assign-layout-slots (layout &key depthoid length - (flags `(layout-flags ,layout)) flagsp) - (let ((invalidate-p (and (eql depthoid -1) (not length) (not flagsp)))) - #+(and 64-bit (not xc-host)) ; packed slot - `(setf (layout-flags ,layout) - ,(if invalidate-p - `(logior (ash -1 (+ 32 sb-vm:n-fixnum-tag-bits)) - (ldb (byte 32 0) (layout-flags ,layout))) - `(pack-layout-flags ,depthoid ,length - (logand ,flags layout-flags-mask)))) - #+(or (not 64-bit) sb-xc-host) ; ordinary slot - (if invalidate-p - `(setf (layout-depthoid ,layout) -1) - `(setf (layout-depthoid ,layout) ,depthoid - (layout-length ,layout) ,length - (layout-flags ,layout) ,flags)))) +) ; end PROGN ;;; True of STANDARD-OBJECT, which include generic functions. -;;; This one includes any class that mixes in STANDARD-OBJECT. (declaim (inline layout-for-pcl-obj-p)) -(defun layout-for-pcl-obj-p (x) - (logtest (layout-flags x) +pcl-object-layout-flag+)) +(defun layout-for-pcl-obj-p (wrapper) + (declare (type wrapper wrapper)) + (logtest (wrapper-flags wrapper) +pcl-object-layout-flag+)) ;;; The CLASSOID structure is a supertype of all classoid types. A ;;; CLASSOID is also a CTYPE structure as recognized by the type @@ -510,8 +430,8 @@ #-sb-xc-host (:pure nil)) ;; the value to be returned by CLASSOID-NAME. (name nil :type symbol) - ;; the current layout for this class, or NIL if none assigned yet - (layout nil :type (or layout null)) + ;; the current WRAPPER for this class, or NIL if none assigned yet + (wrapper nil :type (or null wrapper)) ;; How sure are we that this class won't be redefined? ;; :READ-ONLY = We are committed to not changing the effective ;; slots or superclasses. @@ -528,14 +448,16 @@ ;; otherwise, it's an EQ hash-table mapping CLASSOID objects to the ;; subclass layout that was in effect at the time the subclass was ;; created. - (subclasses nil :type (or null hash-table)) + ;; Initially an alist, and changed to a hash-table at some threshold. + (subclasses nil :type (or list hash-table)) + (%lock nil) ; install it just-in-time, similar to hash-table-lock ;; the PCL class (= CL:CLASS, but with a view to future flexibility ;; we don't just call it the CLASS slot) object for this class, or ;; NIL if none assigned yet (pcl-class nil)) -(defun layout-classoid-name (x) - (classoid-name (layout-classoid x))) +(defun wrapper-classoid-name (x) + (classoid-name (wrapper-classoid x))) ;;;; object types to represent classes @@ -557,13 +479,17 @@ ;;; This translation is done when type specifiers are parsed. Type ;;; system operations (union, subtypep, etc.) should never encounter ;;; translated classes, only their translation. -(def!struct (built-in-classoid (:include classoid) - (:copier nil) - (:constructor !make-built-in-classoid)) +(sb-xc:defstruct (built-in-classoid (:include classoid) (:copier nil) + (:constructor !make-built-in-classoid)) ;; the type we translate to on parsing. If NIL, then this class - ;; stands on its own; or it can be set to :INITIALIZING for a period - ;; during cold-load. - (translation nil :type (or ctype (member nil :initializing)))) + ;; stands on its own + (translation nil :type (or null ctype) :read-only t) + (predicate nil :type (sfunction (t) boolean) :read-only t)) +#+sb-xc-host +(defstruct (built-in-classoid (:include classoid) (:copier nil) + (:constructor !make-built-in-classoid)) + ;; until bootstrap of all CTYPEs, store a dummy value distinct from NIL + (translation nil :type (or null ctype (member :initializing)))) (def!struct (condition-classoid (:include classoid) (:copier nil) @@ -593,6 +519,15 @@ ;; environment of MAKE-CONDITION. (hairy-slots nil :type list)) +;;; STRUCTURE-CLASSOID represents what we need to know about structure +;;; classes. Non-structure "typed" defstructs are a special case, and +;;; don't have a corresponding class. +(def!struct (structure-classoid + (:include classoid) + (:copier nil) + (:constructor make-structure-classoid + (&key name &aux (%bits (pack-ctype-bits classoid name)))))) + ;;;; classoid namespace ;;; We use an indirection to allow forward referencing of class @@ -615,26 +550,6 @@ (declare (ignore env)) `(find-classoid-cell ',(classoid-cell-name self) :create t))) -(defun find-classoid-cell (name &key create) - (let ((real-name (uncross name))) - (cond ((info :type :classoid-cell real-name)) - (create - (get-info-value-initializing :type :classoid-cell real-name - (make-classoid-cell real-name)))))) - -;;; Return the classoid with the specified NAME. If ERRORP is false, -;;; then NIL is returned when no such class exists. -(defun find-classoid (name &optional (errorp t)) - (declare (type symbol name)) - (let ((cell (find-classoid-cell name))) - (cond ((and cell (classoid-cell-classoid cell))) - (errorp - (error 'simple-type-error - :datum nil - :expected-type 'class - :format-control "Class not yet defined: ~S" - :format-arguments (list name)))))) - ;;;; PCL stuff ;;; the CLASSOID that we use to represent type information for @@ -656,57 +571,3 @@ (declaim (freeze-type built-in-classoid condition-classoid standard-classoid static-classoid)) - -#-sb-xc-host -(defun id-to-layout (id) - (maphash (lambda (k v) - (declare (ignore k)) - (when (eql (layout-id v) id) (return-from id-to-layout v))) - (classoid-subclasses (find-classoid 't)))) -(export 'id-to-layout) - -(in-package "SB-C") - -;;; layout for this type being used by the compiler -(define-info-type (:type :compiler-layout) - :type-spec (or layout null) - :default (lambda (name) - (awhen (find-classoid name nil) (classoid-layout it)))) - -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) -(defun ftype-from-fdefn (name) - (declare (ignorable name)) - ;; Again [as in (DEFINE-INFO-TYPE (:FUNCTION :TYPE) ...)] it's - ;; not clear how to generalize the FBOUNDP expression to the - ;; cross-compiler. -- WHN 19990330 - #+sb-xc-host - (specifier-type 'function) - #-sb-xc-host - (let* ((fdefn (sb-kernel::find-fdefn name)) - (fun (and fdefn (fdefn-fun fdefn)))) - (if fun - (handler-bind ((style-warning #'muffle-warning)) - (specifier-type (sb-impl::%fun-type fun))) - (specifier-type 'function))))) - -;;; The parsed or unparsed type for this function, or the symbol :GENERIC-FUNCTION. -;;; Ordinarily a parsed type is stored. Only if the parsed type contains -;;; an unknown type will the original specifier be stored; we attempt to reparse -;;; on each lookup, in the hope that the type becomes known at some point. -;;; If :GENERIC-FUNCTION, the info is recomputed from methods at the time of lookup -;;; and stored back. Method redefinition resets the value to :GENERIC-FUNCTION. -(define-info-type (:function :type) - :type-spec (or ctype (cons (eql function)) (member :generic-function)) - :default #'ftype-from-fdefn) - -(defun summarize-layouts () - (let ((prev -1)) - (dolist (layout (sort (loop for v being each hash-value - of (classoid-subclasses (find-classoid 't)) - collect v) - #'< :key #'sb-kernel:layout-flags)) - (let ((flags (sb-kernel:layout-flags layout))) - (unless (= flags prev) - (format t "Layout flags = ~d~%" flags) - (setq prev flags))) - (format t " ~a~%" layout)))) diff -Nru sbcl-2.1.1/src/code/early-cl.lisp sbcl-2.1.11/src/code/early-cl.lisp --- sbcl-2.1.1/src/code/early-cl.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-cl.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -;;;; miscellaneous stuff about the ANSI standard - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-KERNEL") - -;;; the Common Lisp defined type spec symbols -(defparameter *!standard-type-names* - '(array atom bignum bit bit-vector character compiled-function - complex cons double-float extended-char fixnum float function - hash-table integer keyword list long-float nil null number package - pathname random-state ratio rational real readtable sequence - short-float simple-array simple-bit-vector simple-string simple-vector - single-float standard-char stream string base-char symbol t vector)) - -(define-load-time-global sb-sys::*software-version* nil) - -;;; The BOOLE function dispaches to any logic operation depending on -;;; the value of an argument. Presently, legal selector values are [0..15]. -;;; BOOLE is open coded for calls with any of the constants declared below. - -(defconstant boole-clr 0 - "Boole function op, makes BOOLE return 0.") - -(defconstant boole-set 1 - "Boole function op, makes BOOLE return -1.") - -(defconstant boole-1 2 - "Boole function op, makes BOOLE return integer1.") - -(defconstant boole-2 3 - "Boole function op, makes BOOLE return integer2.") - -(defconstant boole-c1 4 - "Boole function op, makes BOOLE return complement of integer1.") - -(defconstant boole-c2 5 - "Boole function op, makes BOOLE return complement of integer2.") - -(defconstant boole-and 6 - "Boole function op, makes BOOLE return logand of integer1 and integer2.") - -(defconstant boole-ior 7 - "Boole function op, makes BOOLE return logior of integer1 and integer2.") - -(defconstant boole-xor 8 - "Boole function op, makes BOOLE return logxor of integer1 and integer2.") - -(defconstant boole-eqv 9 - "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") - -(defconstant boole-nand 10 - "Boole function op, makes BOOLE return log nand of integer1 and integer2.") - -(defconstant boole-nor 11 - "Boole function op, makes BOOLE return lognor of integer1 and integer2.") - -(defconstant boole-andc1 12 - "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") - -(defconstant boole-andc2 13 - "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") - -(defconstant boole-orc1 14 - "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") - -(defconstant boole-orc2 15 - "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") - diff -Nru sbcl-2.1.1/src/code/early-constants.lisp sbcl-2.1.11/src/code/early-constants.lisp --- sbcl-2.1.1/src/code/early-constants.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-constants.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -10,14 +10,66 @@ (in-package "SB-IMPL") (defconstant-eqx lambda-list-keywords - '(&allow-other-keys - &aux - &body - &environment - &key - &more - &optional - &rest - &whole) - #'equal - "A list of symbols used as lambda list keywords in SBCL.") + '(&allow-other-keys + &aux + &body + &environment + &key + &more + &optional + &rest + &whole) + #'equal + "A list of symbols used as lambda list keywords in SBCL.") + +;;; The BOOLE function dispaches to any logic operation depending on +;;; the value of an argument. Presently, legal selector values are [0..15]. +;;; BOOLE is open coded for calls with any of the constants declared below. + +(defconstant boole-clr 0 + "Boole function op, makes BOOLE return 0.") + +(defconstant boole-set 1 + "Boole function op, makes BOOLE return -1.") + +(defconstant boole-1 2 + "Boole function op, makes BOOLE return integer1.") + +(defconstant boole-2 3 + "Boole function op, makes BOOLE return integer2.") + +(defconstant boole-c1 4 + "Boole function op, makes BOOLE return complement of integer1.") + +(defconstant boole-c2 5 + "Boole function op, makes BOOLE return complement of integer2.") + +(defconstant boole-and 6 + "Boole function op, makes BOOLE return logand of integer1 and integer2.") + +(defconstant boole-ior 7 + "Boole function op, makes BOOLE return logior of integer1 and integer2.") + +(defconstant boole-xor 8 + "Boole function op, makes BOOLE return logxor of integer1 and integer2.") + +(defconstant boole-eqv 9 + "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") + +(defconstant boole-nand 10 + "Boole function op, makes BOOLE return log nand of integer1 and integer2.") + +(defconstant boole-nor 11 + "Boole function op, makes BOOLE return lognor of integer1 and integer2.") + +(defconstant boole-andc1 12 + "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") + +(defconstant boole-andc2 13 + "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") + +(defconstant boole-orc1 14 + "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") + +(defconstant boole-orc2 15 + "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") diff -Nru sbcl-2.1.1/src/code/early-defclass.lisp sbcl-2.1.11/src/code/early-defclass.lisp --- sbcl-2.1.1/src/code/early-defclass.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/code/early-defclass.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,74 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-KERNEL") + +(defun call-with-defining-class (kind name thunk) + (declare (ignorable kind name)) + (with-single-package-locked-error + (:symbol name "defining ~S as a ~(~A~)" kind) + (funcall thunk))) + +(defun preinform-compiler-about-class-type (name forthcoming-info) + ;; Unless the type system already has an actual type attached to + ;; NAME (in which case (1) writing a placeholder value over that + ;; actual type as a compile-time side-effect would probably be a bad + ;; idea and (2) anyway we don't need to modify it in order to make + ;; NAME be recognized as a valid type name) + (when (and forthcoming-info (not (info :type :kind name))) + ;; Tell the compiler to expect a class with the given NAME, by + ;; writing a kind of minimal placeholder type information. This + ;; placeholder will be overwritten later when the class is + ;; defined. + (setf (info :type :kind name) :forthcoming-defclass-type))) + +(symbol-macrolet + ((reader-function-type (specifier-type '(function (t) t))) + (writer-function-type (specifier-type '(function (t t) t)))) + (flet ((proclaim-ftype-for-name (kind name type) + (ecase kind + (condition + (proclaim `(ftype ,(type-specifier type) ,name))) + (class + (when (eq (info :function :where-from name) :assumed) + (sb-c:proclaim-ftype name type nil :defined)))))) + + (defun preinform-compiler-about-accessors (kind readers writers) + (flet ((inform (names type) + (mapc (lambda (name) (proclaim-ftype-for-name kind name type)) + names))) + (inform readers reader-function-type) + (inform writers writer-function-type))) + + (defun preinform-compiler-about-slot-functions (kind slots) + (flet ((inform (slots key type) + (mapc (lambda (slot) + (let ((name (funcall key slot))) + (proclaim-ftype-for-name kind name type))) + slots))) + (inform slots #'sb-pcl::slot-reader-name reader-function-type) + (inform slots #'sb-pcl::slot-boundp-name reader-function-type) + (inform slots #'sb-pcl::slot-writer-name writer-function-type))))) + +(defun %%compiler-defclass (name readers writers slots) + ;; ANSI says (Macro DEFCLASS, section 7.7) that DEFCLASS, if it + ;; "appears as a top level form, the compiler must make the class + ;; name be recognized as a valid type name in subsequent + ;; declarations (as for deftype) and be recognized as a valid class + ;; name for defmethod parameter specializers and for use as the + ;; :metaclass option of a subsequent defclass." + (preinform-compiler-about-class-type name t) + (preinform-compiler-about-accessors 'class readers writers) + (preinform-compiler-about-slot-functions 'class slots)) + +(defun %compiler-defclass (name readers writers slots) + (call-with-defining-class + 'class name + (lambda () + (%%compiler-defclass name readers writers slots)))) diff -Nru sbcl-2.1.1/src/code/early-defmethod.lisp sbcl-2.1.11/src/code/early-defmethod.lisp --- sbcl-2.1.1/src/code/early-defmethod.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-defmethod.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -19,8 +19,8 @@ ;;; - The simple methods can be installed later by the full CLOS implementation. ;;; They play nice by using the same call signature for the "fast function" -(sb-xc:defmacro defmethod (&whole form name lambda-list &rest body - &aux qualifier) +(defmacro defmethod (&whole form name lambda-list &rest body + &aux qualifier) (when (member name '((setf documentation) documentation) :test 'equal) (return-from defmethod `(push ',form *!documentation-methods*))) (when (keywordp lambda-list) @@ -90,25 +90,30 @@ (let* ((methods (the simple-vector (cdr (or (assoc gf-name *!trivial-methods*) (error "No methods on ~S" gf-name))))) + ;; WRAPPER-OF can't be called until its constants have been patched in, + ;; which is potentially too early in cold init especially if trying + ;; to debug to figure out what has been patched in. + ;; And sometimes the thing we need to print is a FMT-CONTROL, + ;; which means we can see a funcallable-instance here. + (arg-wrapper + (cond ((%instancep specialized-arg) (%instance-wrapper specialized-arg)) + ((funcallable-instance-p specialized-arg) (%fun-wrapper specialized-arg)) + ;; Non-instance-like types always call a predicate. + (t #.(find-layout 't)))) (applicable-method ;; Each "method" is represented as a vector: ;; #(# QUALIFIER SPECIALIZER # LAMBDA-LIST SOURCE-LOC) + ;; SPECIALIZER is either a symbol for a classoid, or a genesis-time #. ;; Pick the first applicable one. (find-if (lambda (method) - ;; LAYOUT-OF can't be called until its constants have been patched in, - ;; which is potentially too early in cold init especially if trying - ;; to debug to figure out what has been patched in. - (let ((arg-layout (if (%instancep specialized-arg) - (%instance-layout specialized-arg) - ;; Non-instance types always call a predicate. - #.(find-layout 't)))) - (and (null (svref method 1)) ; only primary methods are candidates - (let ((guard (the symbol (svref method 0)))) - (if (fboundp guard) - (funcall guard specialized-arg) - (let ((test (find-layout (svref method 2)))) - (or (eq test arg-layout) - (find test (layout-inherits arg-layout))))))))) + (and (null (svref method 1)) ; only primary methods are candidates + (let ((guard (the symbol (svref method 0)))) + (if (fboundp guard) + (funcall guard specialized-arg) + (let ((test-wrapper (svref method 2))) + (and (sb-kernel::wrapper-p test-wrapper) + (or (find test-wrapper (wrapper-inherits arg-wrapper)) + (eq arg-wrapper test-wrapper)))))))) methods))) (if applicable-method ;; Call using no permutation-vector / no precomputed next method. diff -Nru sbcl-2.1.1/src/code/early-extensions.lisp sbcl-2.1.11/src/code/early-extensions.lisp --- sbcl-2.1.1/src/code/early-extensions.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-extensions.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,6 +13,38 @@ (in-package "SB-IMPL") +;;; FIXME: a lot of places in the code that should use ARRAY-RANGE +;;; instead use INDEX and vice-versa, but the thing is, we have +;;; a ton of fenceposts errors all over the place regardless. +;;; CLHS glosary reference: +;;; "array total size n. the total number of elements in an array, +;;; computed by taking the product of the dimensions of the array." +;;; and ARRAY-TOTAL-SIZE-LIMIT: +;;; "The upper exclusive bound on the array total size of an array." + +;;; Consider a reduced example for the sake of argument in which +;;; ARRAY-TOTAL-SIZE-LIMIT were 21. +;;; - the largest vector would have LENGTH 20. +;;; - the largest legal index for AREF on it would be 19. +;;; - the largest legal :END on sequence functions would be 20. +;;; Nothing should allow 21. So DEFTYPE ARRAY-RANGE is wrong +;;; and must never be used for anything. +;;; Unfortunately, it's all over mb-util and enc-utf etc. +;;; +;;; *Also* INDEX is wrong, as the comment there says. +;;; To fix these and also SEQUENCE-END: +;;; - INDEX should be `(integer 0 (,1- array-dimension-limit)) +;;; - ARRAY-RANGE should be `(integer 0 (,array-dimension-limit)) +;;; - SEQUENCE-END (in deftypes-for-target) should be +;;; `(OR NULL ARRAY-RANGE) +;;; +;;; A further consideration for INDEX on 64-bit machines is that +;;; if INDEX were equivalent to (UNSIGNED-BYTE n) for some 'n' +;;; then (TYPEP X 'INDEX) can combines FIXNUMP and the range test into +;;; one bit-masking test, depending on the architecture. +;;; Probably it should be (UNSIGNED-BYTE 61) except on ppc64 +;;; where it would have to be (UNSIGNED-BYTE 59). + ;;; A number that can represent an index into a vector, including ;;; one-past-the-end (deftype array-range () @@ -436,6 +468,7 @@ ;; Make a new hash-cache and optionally create the statistics vector. (defun alloc-hash-cache (size symbol) + (declare (type index size)) (let (cache) ;; It took me a while to figure out why infinite recursion could occur ;; in VALUES-SPECIFIER-TYPE. It's because SET calls VALUES-SPECIFIER-TYPE. @@ -605,7 +638,7 @@ (values ,@result-temps)))))) `(progn (pushnew ',var-name *cache-vector-symbols*) - (!define-load-time-global ,var-name nil) + (define-load-time-global ,var-name nil) ,@(when *profile-hash-cache* `((declaim (type (simple-array fixnum (3)) ,statistics-name)) (defvar ,statistics-name))) @@ -1040,6 +1073,12 @@ (defun print-type (stream type &optional colon at) (print-type-specifier stream (type-specifier type) colon at))) +(defun print-lambda-list (stream lambda-list &optional colon at) + (declare (ignore colon at)) + (let ((sb-pretty:*pprint-quote-with-syntactic-sugar* nil) + (*package* *cl-package*)) + (format stream "~:A" lambda-list))) + ;;;; Deprecating stuff @@ -1197,7 +1236,7 @@ (defun setup-type-in-final-deprecation (software version name replacement-spec) (declare (ignore software version replacement-spec)) - (%compiler-deftype name (constant-type-expander name t) nil)) + (%deftype name (constant-type-expander name t) nil)) ;; Given DECLS as returned by from parse-body, and SYMBOLS to be bound ;; (with LET, MULTIPLE-VALUE-BIND, etc) return two sets of declarations: diff -Nru sbcl-2.1.1/src/code/early-fasl.lisp sbcl-2.1.11/src/code/early-fasl.lisp --- sbcl-2.1.1/src/code/early-fasl.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-fasl.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ -;;;; needed-early, or at least meaningful-early, stuff for FASL files - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-FASL") - -;;;; various constants and essentially-constants - -;;; a string which appears at the start of a fasl file header -;;; -;;; This value is used to identify fasl files. Even though this is not -;;; declared as a constant (because ANSI Common Lisp has no facility -;;; for declaring values which are constant under EQUAL but not EQL), -;;; obviously you shouldn't mess with it lightly. If you do set a new -;;; value for some reason, keep these things in mind: -;;; * To avoid confusion with the similar but incompatible CMU CL -;;; fasl file format, the value should not be "FASL FILE", which -;;; is what CMU CL used for the same purpose. -;;; * Since its presence at the head of a file is used by LOAD to -;;; decide whether a file is to be fasloaded or just loaded -;;; ordinarily (as source), the value should be something which -;;; can't legally appear at the head of a Lisp source file. -;;; * The value should not contain any line-terminating characters, -;;; because they're hard to express portably and because the LOAD -;;; code might reasonably use READ-LINE to get the value to compare -;;; against. -(defglobal *fasl-header-string-start-string* "# FASL") - -;;; a list of SB-XC:*FEATURES* flags which affect binary compatibility, -;;; i.e. which must be the same between the SBCL which compiled the code -;;; and the SBCL which executes the code. This is a property of SBCL executables -;;; in the abstract, not of this particular SBCL executable, -;;; so any flag in this list may or may not be present -;;; in the *FEATURES* list of this particular build. -(defglobal *features-potentially-affecting-fasl-format* - (append '(:sb-thread :sb-unicode :cheneygc - :gencgc :msan :sb-safepoint :sb-safepoint-strictly))) - -;;; the code for a character which terminates a fasl file header -(defconstant +fasl-header-string-stop-char-code+ 255) - -;;; This value should be incremented when the system changes in such a -;;; way that it will no longer work reliably with old fasl files. In -;;; practice, I (WHN) have often forgotten to increment it for CVS -;;; versions which break binary compatibility. But it certainly should -;;; be incremented for release versions which break binary -;;; compatibility. -(defconstant +fasl-file-version+ 78) -;;; (description of versions before 0.9.0.1 deleted in 0.9.17) -;;; 56: (2005-05-22) Something between 0.9.0.1 and 0.9.0.14. My money is -;;; on 0.9.0.6 (MORE CASE CONSISTENCY). -;;; 57: (2005-06-12) Raw slot rearrangement in 0.9.1.38 -;;; 58: (2005-08-16) Multiple incompatible changes between 0.9.3 and 0.9.3.60 -;;; 59: (2005-09-18) METAOBJECT implementation, removal of INSTANCE and -;;; FUNCALLABLE-INSTANCE classes. -;;; 60: (2005-10-24) Bumped for 0.9.6 -;;; 61: (2005-11-06) Improved source location recording added extra parameters -;;; to multiple %DEFMUMBLE functions. -;;; 62: (2005-12-30) Make the count of FASL header counted strings -;;; a 32-bit value also on 64-bit platforms. -;;; 63: (2006-01-27) Shuffle storage classes around to reduce the error -;;; trap information size on RISCy platforms. -;;; 64: (2006-03-24) New calling convention for unknown-values on x86 and -;;; x86-64. Also (belatedly) PPC/gencgc, including :gencgc on FPAFF. -;;; 65: (2006-04-11) Package locking interface changed. -;;; 66: (2006-05-13) Fopcompiler -;;; 67: (2006-07-25) Reports on #lisp about 0.9.13 fasls being invalid on -;;; 0.9.14.something -;;; 68: (2006-08-14) changed number of arguments of LOAD-DEFMETHOD -;;; 69: (2006-08-17) changed validity of various initargs for methods -;;; 70: (2006-09-13) changes to *PSEUDO-ATOMIC* on x86 and x86-64 -;;; 71: (2006-11-19) CLOS calling convention changes -;;; 72: (2006-12-05) Added slot to the primitive function type -;;; 73: (2007-04-13) Changed a hash function -;;; 74: (2007-06-05) UNWIND-TO-FRAME-AND-CALL -;;; 75: (2007-08-06) FD-STREAM layout changes -;;; 76: (2007-10-05) MUTEX layout changes -;;; 77: (2007-11-08) Essentially obsolete fasl-file-version, fasls are now -;;; considered compatible only when the version numbers of the compiling -;;; SBCL instance is exactly the same as the one of the loading instance. -;;; Further fasl-file-version bumps should only be done for real changes -;;; in the fasl format, not for changes in function/macro signatures or -;;; lisp data structures. -;;; 78: (2010-04-02) Add FOP-{SMALL-,}NAMED-PACKAGE, remove FOP-NORMAL-LOAD -;;; and FOP-MAYBE-COLD-LOAD. - -;;; the conventional file extension for our fasl files -;;; FIXME this should be (DEFCONSTANT-EQX +FASL-FILE-TYPE+ "fasl" #'EQUAL), -;;; but renaming the variable would harm 'asdf-dependency-grovel' and other -;;; random 3rd-party libraries. However, we can't keep the name and make it -;;; constant, because the compiler warns about asterisks on constants. -;;; So we keep the asterisks and make it defglobal. -(declaim (type simple-string *fasl-file-type*)) -(defglobal *fasl-file-type* "fasl") - -;;;; the FOP database - -(eval-when (:compile-toplevel :load-toplevel :execute) - ;; The bottom 5 bits of the opcodes above 128 encode an implicit operand. - (defconstant n-ordinary-fops 128)) - -;;; a vector indexed by a FaslOP that yields a function which performs -;;; the operation. Most functions take 0 arguments - they only manipulate -;;; the fop stack. But if the fop is defined to receive an argument (or two) -;;; then loader's main loop is responsible for supplying it. -(defglobal **fop-funs** (make-array n-ordinary-fops :initial-element 0)) -(declaim (type (simple-vector #.n-ordinary-fops) **fop-funs**)) - -;;; Two arrays indicate fop function signature. -;;; The first array indicates how many integer operands follow the opcode. -;;; The second tells whether the fop wants its result pushed on the stack. -(declaim (type (cons (simple-array (mod 4) (#.n-ordinary-fops)) - (simple-bit-vector #.n-ordinary-fops)) - **fop-signatures**)) -(defglobal **fop-signatures** - (cons (make-array n-ordinary-fops :element-type '(mod 4) :initial-element 0) - (make-array n-ordinary-fops :element-type 'bit :initial-element 0))) - -;;;; variables - -(defvar *load-depth* 0 - "the current number of recursive LOADs") -(declaim (type index *load-depth*)) - -(defun make-fop-vector (size) - (declare (type index size)) - (let ((vector (make-array size))) - (setf (aref vector 0) 0) - vector)) - -;;; a holder for the FASL file we're reading from -(defstruct (fasl-input (:conc-name %fasl-input-) - (:constructor make-fasl-input (stream)) - (:predicate nil) - (:copier nil)) - (stream nil :type ansi-stream :read-only t) - (table (make-fop-vector 1000) :type simple-vector) - (stack (make-fop-vector 100) :type simple-vector) - (name-buffer (vector (make-string 1 :element-type 'character) - (make-string 31 :element-type 'base-char))) - (deprecated-stuff nil :type list) - ;; Sometimes we want to skip over any FOPs with side-effects (like - ;; function calls) while executing other FOPs. SKIP-UNTIL will - ;; either contain the position where the skipping will stop, or - ;; NIL if we're executing normally. - (skip-until nil :type (or null fixnum))) -(declaim (freeze-type fasl-input)) - -;;; Unique number assigned into high 4 bytes of 64-bit code size slot -;;; so that we can sort the contents of varyobj space in a more-or-less -;;; predictable manner based on the order in which code was loaded. -;;; This wraps around at 32 bits, but it's still deterministic. -(define-load-time-global *code-serialno* 0) -(declaim (fixnum *code-serialno*)) diff -Nru sbcl-2.1.1/src/code/early-float.lisp sbcl-2.1.11/src/code/early-float.lisp --- sbcl-2.1.1/src/code/early-float.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-float.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -17,7 +17,8 @@ ;;;; utilities -(eval-when (:compile-toplevel :load-toplevel :execute) +;;; Don't need to define it in the host in both passes +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) ;;; These functions let us create floats from bits with the ;;; significand uniformly represented as an integer. This is less diff -Nru sbcl-2.1.1/src/code/early-format.lisp sbcl-2.1.11/src/code/early-format.lisp --- sbcl-2.1.1/src/code/early-format.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-format.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-FORMAT") - -(declaim (type (simple-vector 128) - *format-directive-expanders* - *format-directive-interpreters*)) -(defglobal *format-directive-expanders* (make-array 128 :initial-element nil)) -#-sb-xc-host -(!define-load-time-global *format-directive-interpreters* - #.(sb-xc:make-array 128 :initial-element nil)) - -(defvar *default-format-error-control-string* nil) -(defvar *default-format-error-offset* nil) - -;;;; specials used to communicate information - -;;; Used both by the expansion stuff and the interpreter stuff. When it is -;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. -(defvar *up-up-and-out-allowed* nil) - -;;; Used by the interpreter stuff. When it's non-NIL, it's a function -;;; that will invoke PPRINT-POP in the right lexical environemnt. -(defvar *logical-block-popper* nil) -(declaim (type (or null function) *logical-block-popper*) - (always-bound *logical-block-popper*)) - -;;; Used by the expander stuff. This is bindable so that ~<...~:> -;;; can change it. -(defvar *expander-next-arg-macro* 'expander-next-arg) - -;;; Used by the expander stuff. Initially starts as T, and gets set to NIL -;;; if someone needs to do something strange with the arg list (like use -;;; the rest, or something). -(defvar *only-simple-args*) - -;;; Used by the expander stuff. We do an initial pass with this as NIL. -;;; If someone doesn't like this, they (THROW 'NEED-ORIG-ARGS NIL) and we try -;;; again with it bound to T. If this is T, we don't try to do anything -;;; fancy with args. -(defvar *orig-args-available* nil) - -;;; Used by the expander stuff. List of (symbol . offset) for simple args. -(defvar *simple-args*) diff -Nru sbcl-2.1.1/src/code/early-full-eval.lisp sbcl-2.1.11/src/code/early-full-eval.lisp --- sbcl-2.1.1/src/code/early-full-eval.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-full-eval.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,8 +11,8 @@ (in-package "SB-EVAL") -(defparameter *eval-level* -1) ; initialized by genesis -(defparameter *eval-verbose* nil) ; initialized by genesis +(defparameter *eval-level* -1) +(defparameter *eval-verbose* nil) ;; !defstruct-with-alternate-metaclass is unslammable and the ;; RECOMPILE restart doesn't work on it. This is the main reason why diff -Nru sbcl-2.1.1/src/code/early-impl.lisp sbcl-2.1.11/src/code/early-impl.lisp --- sbcl-2.1.1/src/code/early-impl.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-impl.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -27,7 +27,7 @@ sb-unix::*unblock-deferrables-on-enabling-interrupts-p* *interrupts-enabled* *interrupt-pending* - #+sb-thruption *thruption-pending* + #+sb-safepoint *thruption-pending* #+sb-safepoint *in-safepoint* *free-interrupt-context-index* #-gencgc @@ -40,7 +40,7 @@ ;;; and the symbol-global-value should never be used. ;;; (And in any case it is not really a special var) #+(and (or x86 x86-64) (not sb-thread)) -(defparameter *pseudo-atomic-bits* 0) ; initialized by genesis +(defvar *pseudo-atomic-bits* 0) #+c-stack-is-control-stack (setf (info :variable :always-bound 'sb-c:*alien-stack-pointer*) :always-bound) @@ -59,13 +59,13 @@ ;;; comparisons. Unlikely, but the cost of using a cons instead is too ;;; small to measure. -- JES, 2007-09-30 (declaim (type cons sb-kernel::*gc-epoch*)) -(!define-load-time-global sb-kernel::*gc-epoch* '(nil . nil)) +(define-load-time-global sb-kernel::*gc-epoch* '(nil . nil)) ;;; Default evaluator mode (interpeter / compiler) (declaim (type (member :compile #+(or sb-eval sb-fasteval) :interpret) *evaluator-mode*)) -(defparameter *evaluator-mode* :compile ; initialized by genesis +(defparameter *evaluator-mode* :compile "Toggle between different evaluator implementations. If set to :COMPILE, an implementation of EVAL that calls the compiler will be used. If set to :INTERPRET, an interpreter will be used.") diff -Nru sbcl-2.1.1/src/code/early-print.lisp sbcl-2.1.11/src/code/early-print.lisp --- sbcl-2.1.1/src/code/early-print.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-print.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -16,7 +16,7 @@ ;;; The current level we are printing at, to be compared against ;;; *PRINT-LEVEL*. See the macro DESCEND-INTO for a handy interface to ;;; depth abbreviation. -(defparameter *current-level-in-print* 0) ; initialized by genesis +(defvar *current-level-in-print* 0) (declaim (index *current-level-in-print*)) ;;; Automatically handle *PRINT-LEVEL* abbreviation. If we are too @@ -189,8 +189,6 @@ (write-char #\= stream) t))))) -(define-load-time-global *null-broadcast-stream* (make-broadcast-stream)) -(declaim (type stream *null-broadcast-stream*)) (defmacro with-circularity-detection ((object stream) &body body) (with-unique-names (marker body-name) `(labels ((,body-name () diff -Nru sbcl-2.1.1/src/code/early-raw-slots.lisp sbcl-2.1.11/src/code/early-raw-slots.lisp --- sbcl-2.1.1/src/code/early-raw-slots.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-raw-slots.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -45,6 +45,13 @@ ;; these abstractions are provided as soon as the raw slots defs are. (def!type sb-vm:word () `(unsigned-byte ,sb-vm:n-word-bits)) (def!type sb-vm:signed-word () `(signed-byte ,sb-vm:n-word-bits)) + +;;; This constant has a 1 bit meaning "tagged" for every user data slot. +;;; If LAYOUT is not in the header word, then (%INSTANCE-REF instance 0) +;;; indicates as raw so that GC treats layouts consistently, not scanning +;;; them en passant while visiting the payload. Consequently, 0 means either +;;; no slots or all raw, no matter if the layout consumes a slot. +;;; See remarks above CALCULATE-DD-BITMAP for further details. (defconstant +layout-all-tagged+ (ash -1 sb-vm:instance-data-start)) ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed @@ -61,21 +68,29 @@ #-sb-xc-host (comparator (missing-arg) :type function :read-only t) ;; the type specifier, which must specify a numeric type. (raw-type (missing-arg) :type symbol :read-only t) - (init-vop (missing-arg) :type symbol :read-only t) + (init-vop (missing-arg) :type symbol :read-only t) ; FIXME: remove ;; How many words are each value of this type? (n-words (missing-arg) :type (and index (integer 1)) :read-only t) ;; Necessary alignment in units of words. Note that instances ;; themselves are aligned by exactly two words, so specifying more ;; than two words here would not work. (alignment 1 :type (integer 1 2) :read-only t)) - -#-sb-xc-host -(progn (declaim (inline raw-slot-data-accessor-name)) - (defun raw-slot-data-accessor-name (rsd) - (%simple-fun-name (raw-slot-data-accessor-fun rsd)))) - (declaim (freeze-type raw-slot-data)) +(declaim (inline raw-slot-data-reader-name)) +(defun raw-slot-data-reader-name (rsd) + #+sb-xc-host (raw-slot-data-accessor-name rsd) + #-sb-xc-host (%simple-fun-name (raw-slot-data-accessor-fun rsd))) + +(defun raw-slot-data-writer-name (rsd) + (ecase (raw-slot-data-reader-name rsd) + (%raw-instance-ref/word '%raw-instance-set/word) + (%raw-instance-ref/single '%raw-instance-set/single) + (%raw-instance-ref/double '%raw-instance-set/double) + (%raw-instance-ref/signed-word '%raw-instance-set/signed-word) + (%raw-instance-ref/complex-single '%raw-instance-set/complex-single) + (%raw-instance-ref/complex-double '%raw-instance-set/complex-double))) + ;; Simulate DEFINE-LOAD-TIME-GLOBAL - always bound in the image ;; but not eval'd in the compiler. (defglobal *raw-slot-data* nil) @@ -160,34 +175,60 @@ #+sb-xc (declaim (type (simple-vector #.(length *raw-slot-data*)) *raw-slot-data*)) -;; DO-INSTANCE-TAGGED-SLOT iterates over the manifest slots of THING -;; that contain tagged objects. (The LAYOUT does not count as a manifest slot). -;; INDEX-VAR is bound to successive slot-indices, -;; and is usually used as the second argument to %INSTANCE-REF. -;; :PAD, if T, includes a final word that may be present at the end of the -;; structure due to alignment requirements. -;; LAYOUT is optional and somewhat unnecessary, but since some uses of -;; this macro already have a layout in hand, it can be supplied. -;; [If the compiler were smarter about doing fewer memory accesses, -;; there would be no need at all for the LAYOUT - if it had already been -;; accessed, it shouldn't be another memory read] -;; Another use-case for LAYOUT is more esoteric, when 'editcore' manipulates -;; objects in a foreign core. -(defmacro do-instance-tagged-slot ((index-var thing &key ((:layout layout-expr)) (pad t)) +;;; DO-INSTANCE-TAGGED-SLOT iterates over the manifest slots of THING +;;; that contain tagged objects. (The LAYOUT does not count as a manifest slot). +;;; INDEX-VAR is bound to successive slot-indices, +;;; and is usually used as the second argument to %INSTANCE-REF. +#+sb-xc-host +(defmacro do-instance-tagged-slot ((index-var thing) &body body) + (with-unique-names (instance dsd) + `(let ((,instance ,thing)) + (dolist (,dsd (dd-slots (find-defstruct-description (type-of ,instance)))) + (let ((,index-var (dsd-index ,dsd))) + ,@body))))) + +;;; PAD, if T (the default), includes a final word that may be present at the +;;; end of the structure due to alignment requirements. +;;; TYPE should be supplied only by 'editcore' for manipulating an on-disk core +;;; mapped an address that differs from the core's desired address. +;;; I have a love/hate relationship with this macro. +;;; It's more efficient than iterating over DSD-SLOTS, and editcore would +;;; have a harder time using DSD-SLOTS. But it's too complicated. +#-sb-xc-host +(defmacro do-instance-tagged-slot ((index-var thing &optional (pad t) bitmap-expr) &body body) - (with-unique-names (instance layout limit) + (with-unique-names (instance bitmap mask bitmap-index bitmap-limit nbits end) `(let* ((,instance ,thing) - (,layout ,(or layout-expr `(%instance-layout ,instance))) - (,limit ,(if pad - ;; target instances have an odd number of payload words. - `(logior (%instance-length ,instance) #-sb-xc-host 1) - `(%instance-length ,instance)))) - (do ((,index-var sb-vm:instance-data-start (1+ ,index-var))) - ((>= ,index-var ,limit)) + (,bitmap ,(or bitmap-expr `(%instance-layout ,instance))) + ;; Shift out 1 bit if skipping bit 0 of the 0th mask word + ;; because it's not user-visible data. + (,mask (ash (%raw-instance-ref/signed-word ,bitmap (type-dd-length sb-vm:layout)) + (- sb-vm:instance-data-start))) + ;; Start counting from the next bitmap word as we've consumed one already + (,bitmap-index (1+ (type-dd-length sb-vm:layout))) + (,bitmap-limit (%instance-length ,bitmap)) + ;; If this was the last word of the bitmap, then the high bit + ;; is infinitely sign-extended, and we can keep right-shifting + ;; the mask word indefinitely. Most bitmaps will have only 1 word, + ;; so this is almost always MOST-POSITIVE-FIXNUM. + (,nbits (if (= ,bitmap-index ,bitmap-limit) + sb-vm:instance-length-mask + (- sb-vm:n-word-bits sb-vm:instance-data-start)))) + (declare (type sb-vm:signed-word ,mask) + (type fixnum ,nbits)) + (do ((,index-var sb-vm:instance-data-start (1+ ,index-var)) + (,end ,(if pad + ;; target instances have an odd number of payload words. + `(logior (%instance-length ,instance) 1) + `(%instance-length ,instance)))) + ((>= ,index-var ,end)) (declare (type index ,index-var)) - (when #+sb-xc-host (logbitp ,index-var (layout-bitmap ,layout)) - #-sb-xc-host - (multiple-value-bind (word bit) (floor ,index-var sb-vm:n-word-bits) - (logbitp bit (%raw-instance-ref/word - ,layout (+ (type-dd-length layout) word)))) - ,@body))))) + ;; If mask was fully consumed, fetch the next bitmap word + (when (zerop ,nbits) + (setq ,mask (%raw-instance-ref/signed-word ,bitmap ,bitmap-index) + ,nbits (if (= (incf ,bitmap-index) ,bitmap-limit) + sb-vm:instance-length-mask + sb-vm:n-word-bits))) + (when (logbitp 0 ,mask) ,@body) + (setq ,mask (ash ,mask -1) + ,nbits (truly-the fixnum (1- ,nbits))))))) diff -Nru sbcl-2.1.1/src/code/early-source-location.lisp sbcl-2.1.11/src/code/early-source-location.lisp --- sbcl-2.1.1/src/code/early-source-location.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-source-location.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -;;;; Source location tracking macros. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-C") - -#| No calls to #'SOURCE-LOCATION must happen from this file because: -;; - it would imply lack of location information for the definition, -;; since deferring the call past compile-time means we've already lost. -;; - it would be a style-warning to subsequently define the compiler-macro. -;; (DEFINE-COMPILER-MACRO SOURCE-LOCATION) does not itself use SOURCE-LOCATION -;; but this is possibly a mistake! Ordinary DEFMACRO supplies the location -;; to %DEFMACRO. Compiler macros should too. This extra form will be needed: -(eval-when (#+sb-xc :compile-toplevel) - (setf (info :function :compiler-macro-function 'source-location) - (lambda (form env) - (declare (ignore form env)) - (make-definition-source-location)))) |# - -#+sb-source-locations -(progn - #-sb-xc-host - (define-compiler-macro source-location () - (make-definition-source-location)) - ;; We need a regular definition of SOURCE-LOCATION for calls processed - ;; during LOAD on a source file while *EVALUATOR-MODE* is :INTERPRET. - (defun source-location () - #-sb-xc-host (make-definition-source-location))) - -#-sb-source-locations -(defun source-location () nil) - -#-sb-xc-host -(eval-when (:compile-toplevel :load-toplevel :execute) - (dolist (entry '#.sb-vm::per-thread-c-interface-symbols) - (let ((symbol (if (consp entry) (car entry) entry))) - (declare (notinline info (setf info))) - ;; CURRENT-{CATCH/UWP}-BLOCK are thread slots, - ;; so the TLS indices were already assigned. - ;; There may be other symbols too. - (unless (info :variable :wired-tls symbol) - (setf (info :variable :wired-tls symbol) :always-thread-local)) - (unless (info :variable :always-bound symbol) - (setf (info :variable :always-bound symbol) :always-bound))))) diff -Nru sbcl-2.1.1/src/code/early-type.lisp sbcl-2.1.11/src/code/early-type.lisp --- sbcl-2.1.1/src/code/early-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/early-type.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1155 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-KERNEL") - -;; The following macros expand into either constructor calls, -;; if building the cross-compiler, or forms which reference -;; previously constructed objects, if running the cross-compiler. -#+sb-xc-host -(progn - (defmacro literal-ctype (constructor &optional specifier) - (declare (ignore specifier)) - `(load-time-value ,constructor)) - - (defmacro literal-ctype-vector (var) - `(load-time-value ,var nil))) - -;; Omitting the specifier works only if the unparser method has been -;; defined in time to use it, and you're sure that constructor's result -;; can be unparsed - some unparsers may be confused if called on a -;; non-canonical object, such as an instance of (CONS T T) that is -;; not EQ to the interned instance. -#-sb-xc-host -(progn - (defmacro literal-ctype (constructor &optional (specifier nil specifier-p)) - (if specifier-p (specifier-type specifier) (symbol-value constructor))) - - (defmacro literal-ctype-vector (var) - (symbol-value var))) - -(!begin-collecting-cold-init-forms) - -;;;; representations of types - -;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type. -;; e.g. any SATISFIES with a predicate returning T over a finite domain. -;; But in practice there's nothing that can be done with this information, -;; because we don't call random predicates when performing operations on types -;; as objects, only when checking for inclusion of something in the type. -(define-type-class hairy :enumerable t :might-contain-other-types t) - -;;; Without some special HAIRY cases, we massively pollute the type caches -;;; with objects that are all equivalent to *EMPTY-TYPE*. e.g. -;;; (AND (SATISFIES LEGAL-FUN-NAME-P) (SIMPLE-ARRAY CHARACTER (*))) and -;;; (AND (SATISFIES KEYWORDP) CONS). Since the compiler doesn't know -;;; that they're just *EMPTY-TYPE*, its keeps building more and more complex -;;; expressions involving them. I'm not sure why those two are so prevalent -;;; but they definitely seem to be. We can improve performance by reducing -;;; them to *EMPTY-TYPE* which means we need a way to recognize those hairy -;;; types in order reason about them. Interning them is how we recognize -;;; them, as they can be compared by EQ. -#+sb-xc-host -(progn - (defvar *satisfies-keywordp-type* - (!make-interned-hairy-type '(satisfies keywordp))) - (defvar *fun-name-type* - (!make-interned-hairy-type '(satisfies legal-fun-name-p)))) - -;;; An UNKNOWN-TYPE is a type not known to the type system (not yet -;;; defined). We make this distinction since we don't want to complain -;;; about types that are hairy but defined. -(defstruct (unknown-type (:include hairy-type (%bits (pack-ctype-bits hairy))) - (:copier nil))) - -(defun maybe-reparse-specifier (type) - (when (unknown-type-p type) - (let* ((spec (unknown-type-specifier type)) - (name (if (consp spec) - (car spec) - spec))) - (when (info :type :kind name) - (let ((new-type (specifier-type spec))) - (unless (unknown-type-p new-type) - new-type)))))) - -;;; Evil macro. -(defmacro maybe-reparse-specifier! (type) - (aver (symbolp type)) - (with-unique-names (new-type) - `(let ((,new-type (maybe-reparse-specifier ,type))) - (when ,new-type - (setf ,type ,new-type) - t)))) - -(defstruct (negation-type (:include ctype (%bits (pack-ctype-bits negation))) - (:copier nil) - (:constructor make-negation-type (type))) - (type (missing-arg) :type ctype :read-only t)) - -;; Former comment was: -;; FIXME: is this right? It's what they had before, anyway -;; But I think the reason it's right is that "enumerable :t" is equivalent -;; to "maybe" which is actually the conservative assumption, same as HAIRY. -(define-type-class negation :enumerable t :might-contain-other-types t) - -(defun canonicalize-args-type-args (required optional rest &optional keyp) - (when (eq rest *empty-type*) - ;; or vice-versa? - (setq rest nil)) - (loop with last-not-rest = nil - for i from 0 - for opt in optional - do (cond ((eq opt *empty-type*) - (return (values required (subseq optional 0 i) rest))) - ((and (not keyp) (neq opt rest)) - (setq last-not-rest i))) - finally (return (values required - (cond (keyp - optional) - (last-not-rest - (subseq optional 0 (1+ last-not-rest)))) - rest)))) - -;;; CONTEXT is the cookie passed down from the outermost surrounding call -;;; of BASIC-PARSE-TYPE. INNER-CONTEXT-KIND is an indicator of whether -;;; we are currently parsing a FUNCTION or a VALUES compound type specifier. - -;;; Why do we allow * for items in a list for FUNCTION type? I don't know -;;; and I don't think we should. -;;; VALUES is quite clear that it's not allowed. FUNCTION is less clear, -;;; but * is not a type specifier, it is merely a way to write something in a place -;;; where a specifier requires a positional argument that you don't want to supply, -;;; but must supply in order to supply following arguments. -;;; I would bet we're overly permissive. -(defun parse-args-types (context lambda-listy-thing inner-context-kind) - (multiple-value-bind (llks required optional rest keys) - (parse-lambda-list - lambda-listy-thing - :context inner-context-kind - :accept (ecase inner-context-kind - (:values-type (lambda-list-keyword-mask '(&optional &rest))) - (:function-type (lambda-list-keyword-mask - '(&optional &rest &key &allow-other-keys)))) - :silent t) - (labels ((parse-list (list) (mapcar #'parse-one list)) - (parse-one (x) - (if (eq inner-context-kind :function-type) - (single-value-specifier-type x context) ; allow * - ;; "* is not permitted as an argument to the VALUES type specifier." - (specifier-type x context 'values)))) ; forbid * - (let ((required (parse-list required)) - (optional (parse-list optional)) - (rest (when rest (parse-one (car rest)))) - (keywords - (collect ((key-info)) - (dolist (key keys) - (unless (proper-list-of-length-p key 2) - (error "Keyword type description is not a two-list: ~S." key)) - (let ((kwd (first key))) - (when (find kwd (key-info) :key #'key-info-name) - (error "~@" - kwd lambda-listy-thing)) - (key-info - (make-key-info - ;; MAKE-KEY-INFO will complain if KWD is not a symbol. - ;; That's good enough - we don't need an extra check here. - :name kwd - :type (single-value-specifier-type (second key) context))))) - (key-info)))) - (multiple-value-bind (required optional rest) - (canonicalize-args-type-args required optional rest - (ll-kwds-keyp llks)) - (values llks required optional rest keywords)))))) - -(defstruct (values-type - (:include args-type (%bits (pack-ctype-bits values))) - (:constructor %make-values-type) - (:predicate %values-type-p) - (:copier nil))) - -(declaim (inline values-type-p)) -(defun values-type-p (x) - (or (eq x *wild-type*) - (%values-type-p x))) - -(defun-cached (make-values-type-cached - :hash-bits 8 - :hash-function - (lambda (req opt rest allowp) - (logxor (type-list-cache-hash req) - (type-list-cache-hash opt) - (if rest - (type-hash-value rest) - 42) - ;; Results (logand #xFF (sxhash t/nil)) - ;; hardcoded to avoid relying on the xc host. - ;; [but (logand (sxhash nil) #xff) => 2 - ;; for me, so the code and comment disagree, - ;; but not in a way that matters.] - (if allowp - 194 - 11)))) - ((required equal-but-no-car-recursion) - (optional equal-but-no-car-recursion) - (rest eq) - (allowp eq)) - (%make-values-type :required required - :optional optional - :rest rest - :allowp allowp)) - -(defun make-values-type (&key required optional rest allowp) - (multiple-value-bind (required optional rest) - (canonicalize-args-type-args required optional rest) - (cond ((and (null required) - (null optional) - (eq rest *universal-type*)) - *wild-type*) - ((memq *empty-type* required) - *empty-type*) - (t (make-values-type-cached required optional - rest allowp))))) - -(define-type-class values :enumerable nil - :might-contain-other-types nil) - -(define-type-class function :enumerable nil - :might-contain-other-types nil) - -#+sb-xc-host -(defvar *interned-fun-types* - (flet ((fun-type (n) - (!make-interned-fun-type (pack-interned-ctype-bits 'function) - (make-list n :initial-element *universal-type*) - nil nil nil nil nil nil *wild-type*))) - (vector (fun-type 0) (fun-type 1) (fun-type 2) (fun-type 3)))) - -(defun make-fun-type (&key required optional rest - keyp keywords allowp - wild-args returns - designator) - (let ((rest (if (eq rest *empty-type*) nil rest)) - (n (length required))) - (cond (designator - (make-fun-designator-type required optional rest keyp keywords - allowp wild-args returns)) - ((and - (<= n 3) - (not optional) (not rest) (not keyp) - (not keywords) (not allowp) (not wild-args) - (eq returns *wild-type*) - (not (find *universal-type* required :test #'neq))) - (svref (literal-ctype-vector *interned-fun-types*) n)) - (t - (%make-fun-type required optional rest keyp keywords - allowp wild-args returns))))) - -;; This seems to be used only by cltl2, and within 'cross-type', -;; where it is never used, which makes sense, since pretty much we -;; never want this object, but instead the classoid FUNCTION -;; if we know nothing about a function's signature. -;; Maybe this should not exist unless cltl2 is loaded??? -(define-load-time-global *universal-fun-type* - (make-fun-type :wild-args t :returns *wild-type*)) - -;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG -;;; "type specifier", which is only meaningful in function argument -;;; type specifiers used within the compiler. (It represents something -;;; that the compiler knows to be a constant.) -(defstruct (constant-type - (:include ctype (%bits (pack-ctype-bits constant))) - (:copier nil)) - ;; The type which the argument must be a constant instance of for this type - ;; specifier to win. - (type (missing-arg) :type ctype :read-only t)) - -(define-type-class number :enumerable #'numeric-type-enumerable - :might-contain-other-types nil) - -(defun interned-numeric-type (specifier &rest args) - (apply '%make-numeric-type - :%bits (pack-interned-ctype-bits - 'number nil - (when specifier (sb-vm::saetp-index-or-lose specifier))) - args)) - -#+sb-xc-host -(progn - ;; Work around an ABCL bug. This fails to load: - ;; (macrolet ((foo-it (x) `(- ,x))) (defvar *var* (foo-it 3))) - (defvar *interned-signed-byte-types*) - (defvar *interned-unsigned-byte-types*) - (macrolet ((int-type (low high) - `(interned-numeric-type (when (sb-c::find-saetp spec) spec) - :class 'integer :enumerable t - :low ,low :high ,high))) - (setq *interned-signed-byte-types* - (do ((v (make-array sb-vm:n-word-bits)) - (i 1 (1+ i)) - (j -1)) - ((> i sb-vm:n-word-bits) v) - (let ((spec (if (= i sb-vm:n-fixnum-bits) - 'fixnum - `(signed-byte ,i)))) - (setf (svref v (1- i)) (int-type j (lognot j)) - j (ash j 1))))) - (setq *interned-unsigned-byte-types* - (let ((v (make-array (1+ sb-vm:n-word-bits)))) - (dotimes (i (length v) v) - (let ((spec (if (= i 1) 'bit `(unsigned-byte ,i)))) - (setf (svref v i) (int-type 0 (1- (ash 1 i)))))))))) - -;;; Coerce a numeric type bound to the given type while handling -;;; exclusive bounds. -(defun coerce-numeric-bound (bound type) - (flet ((c (thing) - (case type - (rational (rational thing)) - ((float single-float) - (cond #-sb-xc-host - ((<= most-negative-single-float thing most-positive-single-float) - (coerce thing 'single-float)) - (t - (return-from coerce-numeric-bound)))) - (double-float - (cond #-sb-xc-host - ((<= most-negative-double-float thing most-positive-double-float) - (coerce thing 'double-float)) - (t - (return-from coerce-numeric-bound))))))) - (when bound - (if (consp bound) - (list (c (car bound))) - (c bound))))) - -(declaim (inline bounds-unbounded-p)) -(defun bounds-unbounded-p (low high) - (and (null low) (eq high low))) - -;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some -;;; cases, despite the name, we return *EMPTY-TYPE* or a UNION-TYPE instead of a -;;; NUMERIC-TYPE. -;;; -;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that -;;; come from parsing MEMBER. But bounded integer ranges, -;;; however large, are enumerable: -;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T -;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T -;;; but, in contrast, -;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL. -;;; I can't figure out whether this is supposed to matter. -;;; Moreover, it seems like this function should be responsible -;;; for figuring out the right value so that callers don't have to. -(defun make-numeric-type (&key class format (complexp :real) low high - enumerable) - (declare (type (member integer rational float nil) class)) - (macrolet ((unionize (types classes formats) - `(let (types) - (loop for thing in ',types - for class in ',classes - for format in ',formats - do - (let ((low (coerce-numeric-bound low thing)) - (high (coerce-numeric-bound high thing))) - (push (make-numeric-type - :format format - :class class - :complexp complexp - :low low - :high high - :enumerable enumerable) - types))) - (apply #'type-union types)))) - (when (and (null class) (member complexp '(:real :complex))) - (return-from make-numeric-type - (if (bounds-unbounded-p low high) - (if (eq complexp :complex) - (specifier-type 'complex) - (specifier-type 'real)) - (unionize (rational single-float double-float) - (rational float float) - (nil single-float double-float))))) - (when (and (eql class 'float) (member complexp '(:complex :real)) (eql format nil)) - (return-from make-numeric-type - (if (bounds-unbounded-p low high) - (if (eq complexp :complex) - (specifier-type '(complex float)) - (specifier-type 'real)) - (unionize (single-float double-float #+long-float (error "long-float")) - (float float) - (single-float double-float)))))) - (multiple-value-bind (low high) - (case class - (integer - ;; INTEGER types always have their LOW and HIGH bounds - ;; represented as inclusive, not exclusive values. - (values (if (consp low) (1+ (type-bound-number low)) low) - (if (consp high) (1- (type-bound-number high)) high))) - (t - ;; no canonicalization necessary - (values low high))) - ;; if interval is empty - (when (and low high - (if (or (consp low) (consp high)) ; if either bound is exclusive - (sb-xc:>= (type-bound-number low) (type-bound-number high)) - (sb-xc:> low high))) - (return-from make-numeric-type *empty-type*)) - (when (and (eq class 'rational) (integerp low) (eql low high)) - (setf class 'integer)) - ;; Either lookup the canonical interned object for - ;; a point in the type lattice, or construct a new one. - (or (case class - (float - (macrolet ((float-type (fmt complexp - &aux (spec (if (eq complexp :complex) - `(complex ,fmt) fmt))) - `(literal-ctype (interned-numeric-type ',spec - :class 'float :complexp ,complexp - :format ',fmt :enumerable nil) - ,spec))) - (when (bounds-unbounded-p low high) - (ecase format - (single-float - (case complexp - (:real (float-type single-float :real)) - (:complex (float-type single-float :complex)))) - (double-float - (case complexp - (:real (float-type double-float :real)) - (:complex (float-type double-float :complex)))))))) - (integer - (macrolet ((int-type (low high) - `(literal-ctype - (interned-numeric-type nil - :class 'integer :low ,low :high ,high - :enumerable (if (and ,low ,high) t nil)) - (integer ,(or low '*) ,(or high '*))))) - (cond ((neq complexp :real) nil) - ((and (eql low 0) (eql high (1- array-dimension-limit))) - (int-type 0 #.(1- array-dimension-limit))) ; INDEX type - ((null high) - (cond ((not low) (int-type nil nil)) - ((eql low 0) (int-type 0 nil)) - ((eql low (1+ most-positive-fixnum)) - ;; positive bignum - (int-type #.(1+ most-positive-fixnum) nil)))) - ((or (eql high most-positive-word) - ;; is (1+ high) a power-of-2 ? - (and (typep high 'word) (zerop (logand (1+ high) high)))) - (cond ((eql low 0) - (svref (literal-ctype-vector *interned-unsigned-byte-types*) - (integer-length (truly-the word high)))) - ((and (< high most-positive-word) (eql low (lognot high))) - (svref (literal-ctype-vector *interned-signed-byte-types*) - (integer-length (truly-the word high)))))) - ((and (not low) (eql high (1- most-negative-fixnum))) - ;; negative bignum - (int-type nil #.(1- most-negative-fixnum)))))) - (rational - (cond ((and (eq complexp :real) (bounds-unbounded-p low high)) - (literal-ctype (interned-numeric-type nil :class 'rational) - rational)) - ((and (eq complexp :complex) (bounds-unbounded-p low high)) - (literal-ctype (interned-numeric-type nil :complexp :complex - :class 'rational) - (complex rational))))) - ((nil) - (and (not format) - (not complexp) - (bounds-unbounded-p low high) - (literal-ctype (interned-numeric-type nil :complexp nil) number)))) - (%make-numeric-type :class class :format format :complexp complexp - :low low :high high :enumerable enumerable)))) - -(defun modified-numeric-type (base - &key - (class (numeric-type-class base)) - (format (numeric-type-format base)) - (complexp (numeric-type-complexp base)) - (low (numeric-type-low base)) - (high (numeric-type-high base)) - (enumerable (type-enumerable base))) - (make-numeric-type :class class - :format format - :complexp complexp - :low low - :high high - :enumerable enumerable)) - -(defun make-character-set-type (pairs) - ; (aver (equal (mapcar #'car pairs) - ; (sort (mapcar #'car pairs) #'<))) - ;; aver that the cars of the list elements are sorted into increasing order - (when pairs - (do ((p pairs (cdr p))) - ((null (cdr p))) - (aver (<= (caar p) (caadr p))))) - (let ((pairs (let (result) - (do ((pairs pairs (cdr pairs))) - ((null pairs) (nreverse result)) - (destructuring-bind (low . high) (car pairs) - (loop for (low1 . high1) in (cdr pairs) - if (<= low1 (1+ high)) - do (progn (setf high (max high high1)) - (setf pairs (cdr pairs))) - else do (return nil)) - (cond - ((>= low char-code-limit)) - ((< high 0)) - (t (push (cons (max 0 low) - (min high (1- char-code-limit))) - result)))))))) - (unless pairs - (return-from make-character-set-type *empty-type*)) - (unless (cdr pairs) - (macrolet ((range (low high &optional saetp-index) - `(return-from make-character-set-type - (literal-ctype (!make-interned-character-set-type - (pack-interned-ctype-bits 'character-set nil ,saetp-index) - '((,low . ,high))) - (character-set ((,low . ,high))))))) - (let* ((pair (car pairs)) - (low (car pair)) - (high (cdr pair))) - (cond ((eql high (1- char-code-limit)) - (cond ((eql low 0) - (range 0 #.(1- char-code-limit) - (sb-vm::saetp-index-or-lose 'character))) - #+sb-unicode - ((eql low base-char-code-limit) - (range #.base-char-code-limit - #.(1- char-code-limit))))) - #+sb-unicode - ((and (eql low 0) (eql high (1- base-char-code-limit))) - (range 0 #.(1- base-char-code-limit) - (sb-vm::saetp-index-or-lose 'base-char))))))) - (%make-character-set-type pairs))) - -(define-type-class array :enumerable nil - :might-contain-other-types nil) - -;; For all ctypes which are the element types of specialized arrays, -;; 3 ctype objects are stored for the rank-1 arrays of that specialization, -;; one for each of simple, maybe-simple, and non-simple (in that order), -;; and 2 ctype objects for unknown-rank arrays, one each for simple -;; and maybe-simple. (Unknown rank, known-non-simple isn't important) -#+sb-xc-host -(progn -(defvar *interned-array-types* - (labels ((make-1 (type-index dims complexp type) - (aver (= (type-saetp-index type) type-index)) - (!make-interned-array-type (pack-interned-ctype-bits 'array) - dims complexp type type)) - (make-all (element-type type-index array) - (replace array - (list (make-1 type-index '(*) nil element-type) - (make-1 type-index '(*) :maybe element-type) - (make-1 type-index '(*) t element-type) - (make-1 type-index '* nil element-type) - (make-1 type-index '* :maybe element-type)) - :start1 (* type-index 5))) - (integer-range (low high) - (make-numeric-type :class 'integer :complexp :real - :enumerable t :low low :high high))) - (let ((array (make-array (* 32 5))) - (index 0)) - ;; Index 31 is available to store *WILD-TYPE* - ;; because there are fewer than 32 array widetags. - (make-all *wild-type* 31 array) - (dovector (saetp sb-vm:*specialized-array-element-type-properties* - (progn (aver (< index 31)) array)) - (make-all - (let ((x (sb-vm:saetp-specifier saetp))) - ;; Produce element-type representation without parsing a spec. - ;; (SPECIFIER-TYPE doesn't work when bootstrapping.) - ;; The MAKE- constructors return an interned object as appropriate. - (etypecase x - ((cons (eql unsigned-byte)) - (integer-range 0 (1- (ash 1 (second x))))) - ((cons (eql signed-byte)) - (let ((lim (ash 1 (1- (second x))))) - (integer-range (- lim) (1- lim)))) - ((eql bit) (integer-range 0 1)) - ;; FIXNUM is its own thing, why? See comment in vm-array - ;; saying to "See the comment in PRIMITIVE-TYPE-AUX" - ((eql fixnum) ; One good kludge deserves another. - (integer-range most-negative-fixnum - most-positive-fixnum)) - ((member single-float double-float) - (make-numeric-type :class 'float :format x :complexp :real)) - ((cons (eql complex)) - (make-numeric-type :class 'float :format (cadr x) - :complexp :complex)) - ((eql character) - (make-character-set-type `((0 . ,(1- char-code-limit))))) - #+sb-unicode - ((eql base-char) - (make-character-set-type `((0 . ,(1- base-char-code-limit))))) - ((eql t) *universal-type*) - ((eql nil) *empty-type*))) - index - array) - (incf index))))) -(defvar *parsed-specialized-array-element-types* - (let ((a (make-array (length sb-vm:*specialized-array-element-type-properties*)))) - (loop for i below (length a) - do (setf (aref a i) (array-type-specialized-element-type - (aref *interned-array-types* (* i 5))))) - a))) - -(declaim (ftype (sfunction (t &key (:complexp t) - (:element-type t) - (:specialized-element-type t)) - ctype) make-array-type)) -(defun make-array-type (dimensions &key (complexp :maybe) element-type - (specialized-element-type *wild-type*)) - (if (and (eq element-type specialized-element-type) - (or (and (eq dimensions '*) (neq complexp t)) - (typep dimensions '(cons (eql *) null)))) - (let ((res (svref (literal-ctype-vector *interned-array-types*) - (+ (* (type-saetp-index element-type) 5) - (if (listp dimensions) 0 3) - (ecase complexp ((nil) 0) ((:maybe) 1) ((t) 2)))))) - (aver (eq (array-type-element-type res) element-type)) - res) - (%make-array-type dimensions - complexp element-type specialized-element-type))) - -(define-type-class member :enumerable t - :might-contain-other-types nil) - -(declaim (ftype (sfunction (xset list) ctype) make-member-type)) -(defun member-type-from-list (members) - (let ((xset (alloc-xset)) - (fp-zeroes)) - (dolist (elt members (make-member-type xset fp-zeroes)) - (if (fp-zero-p elt) - (pushnew elt fp-zeroes) - (add-to-xset elt xset))))) -(defun make-eql-type (elt) (member-type-from-list (list elt))) -;; Return possibly a union of a MEMBER type and a NUMERIC type, -;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET -;; and the FP-ZEROES. XSET should not contains characters or real numbers. -(defun make-member-type (xset fp-zeroes) - ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can - ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric - ;; ranges are compared by arithmetic operators (while MEMBERship is - ;; compared by EQL). -- CSR, 2003-04-23 - (let ((presence 0) - (unpaired nil) - (float-types nil)) - (when fp-zeroes ; avoid doing two passes of nothing - (dotimes (pass 2) - (dolist (z fp-zeroes) - (let ((sign (float-sign-bit z)) - (pair-idx - (etypecase z - (single-float 0) - (double-float 2 - #+long-float (long-float 4))))) - (if (= pass 0) - (setf (ldb (byte 1 (+ pair-idx sign)) presence) 1) - (if (= (ldb (byte 2 pair-idx) presence) #b11) - (when (= sign 0) - (push (ctype-of z) float-types)) - (push z unpaired))))))) - (let ((member-type - (block nil - (unless unpaired - (macrolet ((member-type (&rest elts) - `(literal-ctype - (!make-interned-member-type - (pack-interned-ctype-bits 'member) (xset-from-list ',elts) nil) - (member ,@elts)))) - (let ((elts (xset-data xset))) - (when (singleton-p elts) - (case (first elts) - ((nil) (return (member-type nil))) - ((t) (return (member-type t))))) - (when (or (equal elts '(t nil)) (equal elts '(nil t))) - ;; Semantically this is fine - XSETs - ;; are not order-preserving except by accident - ;; (when not represented as a hash-table). - (return (member-type t nil)))))) - (when (or unpaired (not (xset-empty-p xset))) - (%make-member-type xset unpaired))))) - ;; The actual member-type contains the XSET (with no FP zeroes), - ;; and a list of unpaired zeroes. - (if float-types - (make-union-type t (if member-type - (cons member-type float-types) - float-types)) - (or member-type *empty-type*))))) - -(defun member-type-size (type) - (+ (length (member-type-fp-zeroes type)) - (xset-count (member-type-xset type)))) - -(defun member-type-member-p (x type) - (if (fp-zero-p x) - (and (member x (member-type-fp-zeroes type)) t) - (xset-member-p x (member-type-xset type)))) - -(defun mapcar-member-type-members (function type) - (declare (function function)) - (collect ((results)) - (map-xset (lambda (x) - (results (funcall function x))) - (member-type-xset type)) - (dolist (zero (member-type-fp-zeroes type)) - (results (funcall function zero))) - (results))) - -(defun mapc-member-type-members (function type) - (declare (function function)) - (map-xset function (member-type-xset type)) - (dolist (zero (member-type-fp-zeroes type)) - (funcall function zero))) - -(defun member-type-members (type) - (append (member-type-fp-zeroes type) - (xset-members (member-type-xset type)))) - -;;; Return TYPE converted to canonical form for a situation where the -;;; "type" '* (which SBCL still represents as a type even though ANSI -;;; CL defines it as a related but different kind of placeholder) is -;;; equivalent to type T. -(defun type-*-to-t (type) - (if (type= type *wild-type*) - *universal-type* - type)) - -(define-type-class cons :enumerable nil :might-contain-other-types nil) - -#+sb-xc-host -(declaim (ftype (sfunction (ctype ctype) (values t t)) type=)) -(defun make-cons-type (car-type cdr-type) - (aver (not (or (eq car-type *wild-type*) - (eq cdr-type *wild-type*)))) - (cond ((or (eq car-type *empty-type*) - (eq cdr-type *empty-type*)) - *empty-type*) - ;; It's not a requirement that (CONS T T) be interned, - ;; but it improves the hit rate in the function caches. - ((and (type= car-type *universal-type*) - (type= cdr-type *universal-type*)) - (literal-ctype (!make-interned-cons-type (pack-interned-ctype-bits 'cons) - *universal-type* - *universal-type*) - cons)) - (t - (%make-cons-type car-type cdr-type)))) - -;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type. -#+sb-simd-pack -(defstruct (simd-pack-type - (:include ctype (%bits (pack-ctype-bits simd-pack))) - (:constructor %make-simd-pack-type (element-type)) - (:copier nil)) - (element-type (missing-arg) - :type (cons #||(member #.*simd-pack-element-types*) ||#) - :read-only t)) - -#+sb-simd-pack-256 -(defstruct (simd-pack-256-type - (:include ctype (%bits (pack-ctype-bits simd-pack-256))) - (:constructor %make-simd-pack-256-type (element-type)) - (:copier nil)) - (element-type (missing-arg) - :type (cons #||(member #.*simd-pack-element-types*) ||#) - :read-only t)) - -#+sb-simd-pack -(defun make-simd-pack-type (element-type) - (aver (neq element-type *wild-type*)) - (if (eq element-type *empty-type*) - *empty-type* - (%make-simd-pack-type - (dolist (pack-type *simd-pack-element-types* - (error "~S element type must be a subtype of ~ - ~{~/sb-impl:print-type-specifier/~#[~;, or ~ - ~:;, ~]~}." - 'simd-pack *simd-pack-element-types*)) - (when (csubtypep element-type (specifier-type pack-type)) - (return (list pack-type))))))) - -#+sb-simd-pack-256 -(defun make-simd-pack-256-type (element-type) - (aver (neq element-type *wild-type*)) - (if (eq element-type *empty-type*) - *empty-type* - (%make-simd-pack-256-type - (dolist (pack-type *simd-pack-element-types* - (error "~S element type must be a subtype of ~ - ~{~/sb-impl:print-type-specifier/~#[~;, or ~ - ~:;, ~]~}." - 'simd-pack-256 *simd-pack-element-types*)) - (when (csubtypep element-type (specifier-type pack-type)) - (return (list pack-type))))))) - -;;;; type utilities - -;;; Return the type structure corresponding to a type specifier. -;;; -;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a -;;; type is defined (or redefined). -;;; -;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily -;;; to the CLHS intent, which is to make the type known to the compiler. -;;; If we compile in one file: -;;; (DEFCLASS FRUITBAT () ()) -;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT)) -;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its -;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF, -;;; which (correctly) signals an error if the class were not defined by the -;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier -;;; at call time is wrong. -;;; -;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton -;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and -;;; (CHARACTER) are not. It has to do with whether the primitive is actually -;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal. -;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis] -;;; compound type specifier with no arguments supplied, (x)." -;;; By that same reasonining, is (x) accepted if x names a class? -;;; - -;;; The xc host uses an ordinary hash table for memoization. -#+sb-xc-host -(let ((table (make-hash-table :test 'equal))) - (defun !values-specifier-type-memo-wrapper (thunk specifier) - (multiple-value-bind (type yesp) (gethash specifier table) - (if yesp - type - (setf (gethash specifier table) (funcall thunk))))) - (defun values-specifier-type-cache-clear () - (clrhash table))) -;;; This cache is sized extremely generously, which has payoff -;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions, -;;; since EQ types are an immediate win. -#-sb-xc-host -(sb-impl::!define-hash-cache values-specifier-type - ((orig equal-but-no-car-recursion)) () - :hash-function #'sxhash :hash-bits 10) - -(declaim (inline make-type-context)) -(defstruct (type-context - (:constructor make-type-context - (spec &optional proto-classoid (cacheable t))) - (:copier nil) - (:predicate nil)) - (spec nil :read-only t) - (proto-classoid nil :read-only t) - (cacheable t)) - -;;; Maintain a table of symbols designating unknown types that have any references -;;; to them, making it easy to inquire whether such things exist. This is at a lower -;;; layer than the parser cache - it's a cache of the constructor itself - so we'll -;;; sitll signal that an unknown specifier is unknown on each reparse of the same. -;;; But as long as any reference enlivens the relevant CTYPE, we'll return that object. -(defglobal **unknown-type-atoms** - ;; This table is specified as unsynchronized because we need to wrap the lock - ;; around a read/modify/write. GETHASH and PUTHASH can't do that themselves. - (sb-impl::make-system-hash-table :test 'eq :weakness :value :synchronized nil)) - -#-sb-xc-host -(progn (declaim (inline class-classoid)) - (defun class-classoid (class) - (layout-classoid (sb-pcl::class-wrapper class)))) - -;;; Parsing of type specifiers comes in many variations: -;;; SINGLE-VALUE-SPECIFIER-TYPE: -;;; disallow VALUES even if single value, but allow * -;;; SPECIFIER-TYPE: -;;; disallow (VALUES ...) even if single value, and disallow * -;;; VALUES-SPECIFIER-TYPE: -;;; allow VALUES and * -;;; TYPE-OR-NIL-IF-UNKNOWN: -;;; like SPECIFIER-TYPE, but return NIL if contains unknown -;;; all the above are funneled through BASIC-PARSE-TYPESPEC. - -;;; The recursive %PARSE-TYPE function is used for nested invocations -;;; of type spec parsing, passing the outermost context through on each call. -;;; Callers should use the BASIC-PARSE-TYPESPEC interface. - -;;; Hint for when you bork this and/or bork the :UNPARSE methods - do: -;;; (remove-method #'print-object (find-method #'print-object nil -;;; (list (find-class 'ctype) (find-class 't)))) -;;; so that 'backtrace' doesn't encounter an infinite chain of errors. - -(macrolet ((fail (spec) - `(error "bad thing to be a type specifier: ~/sb-impl:print-type-specifier/" - ,spec))) -(defun %parse-type (spec context) - (declare (type type-context context)) - (prog* ((head (if (listp spec) (car spec) spec)) - (builtin (if (symbolp head) - (info :type :builtin head) - (return (fail spec))))) - (when (deprecated-thing-p 'type head) - (setf (type-context-cacheable context) nil) - (signal 'parse-deprecated-type :specifier spec)) - (when (atom spec) - ;; If spec is non-atomic, the :BUILTIN value is inapplicable. - ;; There used to be compound builtins, but not any more. - (when builtin (return builtin)) - ;; Any spec that apparently refers to a defstruct form - ;; that's being macroexpanded should refer to that type. - (awhen (type-context-proto-classoid context) - (when (eq (classoid-name it) spec) (return it))) - (case (info :type :kind spec) - (:instance (return (find-classoid spec))) - (:forthcoming-defclass-type (go unknown)))) - ;; Expansion brings up an interesting question - should the cache - ;; contain entries for intermediary types? Say A -> B -> REAL. - ;; As it stands, we cache the ctype corresponding to A but not B. - (awhen (info :type :expander head) - (when (listp it) ; The function translates directly to a CTYPE. - (return (or (funcall (car it) context spec) (fail spec)))) - ;; The function produces a type expression. - (let ((expansion (funcall it (ensure-list spec)))) - (return (if (typep expansion 'instance) - (basic-parse-typespec expansion context) - (%parse-type expansion context))))) - ;; If the spec is (X ...) and X has neither a translator - ;; nor expander, and is a builtin, such as FIXNUM, fail now. - ;; But - see FIXME at top - it would be consistent with - ;; DEFTYPE to reject spec only if not a singleton. - (when builtin (return (fail spec))) - ;; SPEC has a legal form, so return an unknown type. - (signal 'parse-unknown-type :specifier spec) - UNKNOWN - (setf (type-context-cacheable context) nil) - (return (if (atom spec) - (let ((table **unknown-type-atoms**)) - (with-system-mutex ((hash-table-lock table)) - (or (gethash spec table) - (progn #+sb-xc-host - (when cl:*compile-print* - (format t "~&; NEW UNKNOWN-TYPE ~S~%" spec)) - (setf (gethash spec table) - (make-unknown-type :specifier spec)))))) - (make-unknown-type :specifier spec))))) - -;;; BASIC-PARSE-TYPESPEC can grok some simple cases that involve turning an object -;;; used as a type specifier into an internalized type object (which might be -;;; the selfsame object, in the case of a CLASSOID). -(defun basic-parse-typespec (type-specifier context) - (declare (type type-context context)) - (when (typep type-specifier 'instance) - ;; An instance never needs the type parser cache, because it almost always - ;; represents itself or a slot in itself. - (flet ((classoid-to-ctype (classoid) - ;; A few classoids have translations, - ;; e.g. the classoid CONS is a CONS-TYPE. - ;; Hmm, perhaps this should signal PARSE-UNKNOWN-TYPE - ;; if CLASSOID is an instance of UNDEFINED-CLASSOID ? - ;; Can that happen? - (or (and (built-in-classoid-p classoid) - (built-in-classoid-translation classoid)) - classoid))) - (return-from basic-parse-typespec - (cond ((classoid-p type-specifier) (classoid-to-ctype type-specifier)) - ;; Avoid TYPEP on SB-MOP:EQL-SPECIALIZER and CLASS because - ;; the fake metaobjects do not allow type analysis, and - ;; would cause a compiler error as it tries to decide - ;; whether any clause of this COND subsumes another. - ;; Moreover, we don't require the host to support MOP. - #-sb-xc-host - ((sb-pcl::classp type-specifier) - ;; A CLOS class is translated to its CLASSOID, or the classoid's translation. - (classoid-to-ctype (sb-pcl::class-classoid type-specifier))) - #-sb-xc-host - ((sb-pcl::eql-specializer-p type-specifier) - ;; EQL specializers are are seldom used and not 100% portable, - ;; though they are part of the AMOP. - ;; See https://sourceforge.net/p/sbcl/mailman/message/11217378/ - ;; We implement the notion that an EQL-SPECIALIZER has-a CTYPE. - ;; You might think that a cleverer way would be to say that - ;; EQL-SPECIALIZER is-a CTYPE, i.e. incorporating EQL-SPECIALIZER - ;; objects into the type machinary. Well, that's a problem - - ;; it would mess up admissibility of the TYPE= optimization. - ;; We don't want to create another way of representing - ;; the type NULL = (MEMBER NIL), for example. - (sb-pcl::eql-specializer-to-ctype type-specifier)) - ((layout-p type-specifier) - (layout-classoid type-specifier)) - (t (fail type-specifier)))))) - (when (atom type-specifier) - ;; Try to bypass the cache, which avoids using a cache line for standard - ;; atomic specifiers. This is a trade-off- cache seek might be faster, - ;; but this solves the problem that a full call to (TYPEP #\A 'FIXNUM) - ;; consed a cache line every time the cache missed on FIXNUM (etc). - (awhen (info :type :builtin type-specifier) - (return-from basic-parse-typespec it))) - - ;; If CONTEXT was non-cacheable as supplied, the cache is bypassed - ;; for any nested lookup, and we don't insert the result. - (if (not (type-context-cacheable context)) - (%parse-type (uncross type-specifier) context) - ;; Otherwise, try for a cache hit first, and usually update the cache. - (!values-specifier-type-memo-wrapper - (lambda () - (let ((answer (%parse-type (uncross type-specifier) context))) - (if (type-context-cacheable context) - answer - ;; Lookup was cacheable, but result isn't. - ;; Non-caching ensures that we see every occurrence of an unknown - ;; type no matter how deeply nested it is in the expression. - ;; e.g. (OR UNKNOWN-FOO CONS) and (OR INTEGER UNKNOWN-FOO) - ;; should both signal the PARSE-UNKNOWN condition, which would - ;; not happen if the first cached UNKNOWN-FOO. - - ;; During make-host-2 I'm seeing the types &OPTIONAL-AND-&KEY-IN-LAMBDA-LIST, - ;; SIMPLE-ERROR, DISASSEM-STATE as non-cacheable, - ;; and much, much more during make-target-2. - ;; The condition types are obvious, because we mention them before - ;; defining them. - ;; DISASSEM-STATE comes from building **TYPE-SPEC-INTERR-SYMBOLS** - ;; where we have a fixed list of types which get assigned single-byte - ;; error codes. - (progn - #+nil - (unless (type-context-cacheable context) - (format t "~&non-cacheable: ~S ~%" type-specifier)) - (return-from basic-parse-typespec answer))))) - type-specifier))) -) ; end MACROLET - -;;; This takes no CONTEXT (which implies lack of recursion) because -;;; you can't reasonably place a VALUES type inside another type. -(defun values-specifier-type (type-specifier) - (dx-let ((context (make-type-context type-specifier))) - (basic-parse-typespec type-specifier context))) - -;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to -;;; never return a VALUES type. -;;; CONTEXT is either an instance of TYPE-CONTEXT or NIL. -;;; SUBCONTEXT is a symbol denoting the head of the current expression, or NIL. -(defun specifier-type (type-specifier &optional context subcontext) - (let ((ctype - (if context - (basic-parse-typespec type-specifier context) - (dx-let ((context (make-type-context type-specifier))) - (basic-parse-typespec type-specifier context))))) - (when (values-type-p ctype) - ;; We have to see how it was spelled to give an intelligent message. - ;; If it's instance of VALUES-TYPE, then it was spelled as VALUES - ;; whereas if it isn't, the user either spelled it as (VALUES) or *. - ;; The case where this heuristic doesn't work is a DEFTYPE that expands - ;; to *, but that's not worth worrying about. - (cond ((or (%values-type-p ctype) (consp type-specifier)) - (error "VALUES type illegal in this context:~% ~ - ~/sb-impl:print-type-specifier/" - type-specifier)) - (subcontext - (error "* is not permitted as an argument to the ~S type specifier" - subcontext)) - (t - (error "* is not permitted as a type specifier~@[ in the context ~S~]" - ;; If the entire surrounding context is * then there's not much - ;; else to say. Otherwise, show the original expression. - (when (and context (neq (type-context-spec context) '*)) - (type-context-spec context)))))) - ctype)) - -(defun single-value-specifier-type (x &optional context) - (if (eq x '*) - *universal-type* - (specifier-type x context))) - -;;; Parse TYPE-SPECIFIER, returning NIL if any sub-part of it is unknown -(defun type-or-nil-if-unknown (type-specifier &optional allow-values) - (dx-let ((context (make-type-context type-specifier))) - (let ((result (if allow-values - (basic-parse-typespec type-specifier context) - (specifier-type type-specifier context)))) - ;; If it was non-cacheable, either it contained a deprecated type - ;; or unknown type, or was a pending defstruct definition. - (if (and (not (type-context-cacheable context)) - (contains-unknown-type-p result)) - nil - result)))) - -(defun typexpand-1 (type-specifier &optional env) - "Takes and expands a type specifier once like MACROEXPAND-1. -Returns two values: the expansion, and a boolean that is true when -expansion happened." - (declare (type type-specifier type-specifier)) - (declare (type lexenv-designator env) (ignore env)) - (let* ((spec type-specifier) - (atom (if (listp spec) (car spec) spec)) - (expander (and (symbolp atom) (info :type :expander atom)))) - ;; We do not expand builtins even though it'd be - ;; possible to do so sometimes (e.g. STRING) for two - ;; reasons: - ;; - ;; a) From a user's point of view, CL types are opaque. - ;; - ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING)) - (if (and (functionp expander) (not (info :type :builtin atom))) - (values (funcall expander (if (symbolp spec) (list spec) spec)) t) - (values type-specifier nil)))) - -(defun typexpand (type-specifier &optional env) - "Takes and expands a type specifier repeatedly like MACROEXPAND. -Returns two values: the expansion, and a boolean that is true when -expansion happened." - ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to - ;; defer to TYPEXPAND-1 for the typecheck. Similarly for ENV. - (multiple-value-bind (expansion expanded) - (typexpand-1 type-specifier env) - (if expanded - (values (typexpand expansion env) t) - (values expansion expanded)))) - -;;; Note that the type NAME has been (re)defined, updating the -;;; undefined warnings and VALUES-SPECIFIER-TYPE cache. -(defun %note-type-defined (name) - (declare (symbol name)) - (note-name-defined name :type) - (values-specifier-type-cache-clear) - (values)) - - -(!defun-from-collected-cold-init-forms !early-type-cold-init) - -;;; When cross-compiling SPECIFIER-TYPE with a quoted argument, -;;; it can be rendered as a literal object unless it mentions -;;; certain classoids. -;;; -;;; This is important for type system initialization. -;;; -;;; After the target is built, we remove this transform, both because calls -;;; to SPECIFIER-TYPE do not arise organically through user code, -;;; and because it is possible that user changes to types could make parsing -;;; return a different thing, e.g. changing a DEFTYPE to a DEFCLASS. -;;; -#+sb-xc-host -(labels ((xform (type-spec env parser) - (if (not (constantp type-spec env)) - (values nil t) - (let* ((expr (constant-form-value type-spec env)) - (parse (funcall parser expr))) - (if (cold-dumpable-type-p parse) - parse - (values nil t))))) - (cold-dumpable-type-p (ctype) - (when (contains-unknown-type-p ctype) - (bug "SPECIFIER-TYPE transform parsed an unknown type: ~S" ctype)) - (map-type (lambda (type) - (when (and (classoid-p type) (eq (classoid-name type) 'class)) - (return-from cold-dumpable-type-p nil))) - ctype) - t)) - (sb-c:define-source-transform specifier-type (type-spec &environment env) - (xform type-spec env #'specifier-type)) - (sb-c:define-source-transform values-specifier-type (type-spec &environment env) - (xform type-spec env #'values-specifier-type))) diff -Nru sbcl-2.1.1/src/code/error.lisp sbcl-2.1.11/src/code/error.lisp --- sbcl-2.1.1/src/code/error.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/error.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,12 +20,12 @@ (declare (explicit-check) (dynamic-extent arguments)) (cond ((and (%instancep datum) - (let ((layout (%instance-layout datum))) - (and (logtest +condition-layout-flag+ (layout-flags layout)) + (let ((wrapper (%instance-wrapper datum))) + (and (logtest (wrapper-flags wrapper) +condition-layout-flag+) ;; An invalid layout will drop into the (MAKE-CONDITION) branch ;; which rightly fails because ALLOCATE-CONDITION asserts that ;; the first argument is a condition-designator, which it won't be. - (not (layout-invalid layout))))) + (not (wrapper-invalid wrapper))))) (when (and arguments (not (eq fun-name 'cerror))) (cerror "Ignore the additional arguments." 'simple-type-error @@ -69,7 +69,7 @@ ;; is one dx cons cell for the whole cluster. ;; Otherwise it takes 1+2N cons cells where N is the number of bindings. ;; - (collect ((local-functions) (cluster-entries) (dummy-forms)) + (collect ((local-functions) (cluster-entries) (dummy-forms) (complex-initforms)) (flet ((const-cons (test handler) ;; If possible, render HANDLER as a load-time constant so that ;; consing the test and handler is also load-time constant. @@ -166,34 +166,41 @@ ;; Unless the expression is ({FUNCTION|QUOTE} ), then create a ;; new local function. If the supplied handler is spelled ;; (LAMBDA ...) or #'(LAMBDA ...), then the local function is the - ;; lambda but named. If not spelled as such, the function funcalls - ;; the user's sexpr so that the compiler enforces callable-ness. + ;; lambda but named. If not spelled as such, the function funcalls + ;; the user's sexpr through a variable binding so that the compiler + ;; enforces callable-ness but evaluates the supplied form only once. (if (typep handler '(cons (member function quote) (cons symbol null))) handler - (let ((lexpr - (typecase handler - ;; These two are merely expansion prettifiers, - ;; and not strictly necessary. - ((cons (eql function) (cons (cons (eql lambda)) null)) - (cadr handler)) - ((cons (eql lambda)) - handler) - (t - ;; Should be (THE (FUNCTION-DESIGNATOR (CONDITION))) - ;; but the cast kills DX allocation. - `(lambda (c) (funcall ,handler c))))) - (name (let ((*gensym-counter* - (length (cluster-entries)))) - (sb-xc:gensym "H")))) - (local-functions `(,name ,@(rest lexpr))) + (let* ((name (let ((*gensym-counter* + (length (cluster-entries)))) + (sb-xc:gensym "H"))) + (lexpr + (typecase handler + ;; These two are merely expansion prettifiers, + ;; and not strictly necessary. + ((cons (eql function) (cons (cons (eql lambda)) null)) + (cadr handler)) + ((cons (eql lambda)) + handler) + (t + (complex-initforms `(,name ,handler)) + ;; Should be (THE (FUNCTION-DESIGNATOR (CONDITION))) + ;; but the cast kills DX allocation. + `(lambda (c) (funcall ,name c)))))) + (local-functions + `(,name ,(cadr lexpr) + ,@(when (typep (cadr lexpr) '(cons t null)) + '((declare (sb-c::local-optimize (sb-c::verify-arg-count 0))))) + ,@(cddr lexpr))) `#',name)))))))) - `(dx-flet ,(local-functions) - ,@(dummy-forms) - (dx-let ((*handler-clusters* - (cons ,(const-list (cluster-entries)) - *handler-clusters*))) - ,form))))) + `(let ,(complex-initforms) + (dx-flet ,(local-functions) + ,@(dummy-forms) + (dx-let ((*handler-clusters* + (cons ,(const-list (cluster-entries)) + *handler-clusters*))) + ,form)))))) (sb-xc:defmacro handler-bind (bindings &body forms) "(HANDLER-BIND ( {(type handler)}* ) body) @@ -235,7 +242,7 @@ (annotated-cases (mapcar (lambda (case) (with-current-source-form (case) - (with-unique-names (tag fun) + (with-unique-names (block fun) (destructuring-bind (type ll &body body) case (unless (and (listp ll) (symbolp (car ll)) @@ -245,47 +252,43 @@ (multiple-value-bind (body declarations) (parse-body body nil) (push `(,fun ,ll ,@declarations (progn ,@body)) local-funs)) - (list tag type ll fun))))) + (list block type ll fun))))) cases))) - (with-unique-names (block cell form-fun) - `(dx-flet ((,form-fun () - #-x86 (progn ,form) ;; no declarations are accepted - ;; Need to catch FP errors here! - #+x86 (multiple-value-prog1 ,form (float-wait))) - ,@(reverse local-funs)) - (declare (optimize (sb-c::check-tag-existence 0))) - (block ,block - ;; KLUDGE: We use a dx CONS cell instead of just assigning to - ;; the variable directly, so that we can stack allocate - ;; robustly: dx value cells don't work quite right, and it is - ;; possible to construct user code that should loop - ;; indefinitely, but instead eats up some stack each time - ;; around. - (dx-let ((,cell (cons :condition nil))) - (declare (ignorable ,cell)) - (tagbody - (%handler-bind - ,(mapcar (lambda (annotated-case) - (destructuring-bind (tag type ll fun-name) annotated-case - (declare (ignore fun-name)) - (list type - `(lambda (temp) - ,(if ll - `(setf (cdr ,cell) temp) - '(declare (ignore temp))) - (go ,tag))))) - annotated-cases) - (return-from ,block (,form-fun))) - ,@(mapcan - (lambda (annotated-case) - (destructuring-bind (tag type ll fun-name) annotated-case - (declare (ignore type)) - (list tag - `(return-from ,block - ,(if ll - `(,fun-name (cdr ,cell)) - `(,fun-name)))))) - annotated-cases)))))))))) + (with-unique-names (block form-fun) + (let ((body `(%handler-bind + ,(mapcar (lambda (annotated-case) + (destructuring-bind (block type ll fun-name) annotated-case + (declare (ignore fun-name)) + (list type + `(lambda (temp) + ,@(unless ll + `((declare (ignore temp)))) + (return-from ,block + ,@(and ll '(temp))))))) + annotated-cases) + (return-from ,block (,form-fun))))) + (labels ((wrap (cases) + (if cases + (destructuring-bind (fun-block type ll fun-name) (car cases) + (declare (ignore type)) + `(return-from ,block + ,(if ll + `(,fun-name (block ,fun-block + ,(wrap (cdr cases)))) + `(progn (block ,fun-block + ,(wrap (cdr cases))) + (,fun-name))))) + body))) + `(flet ((,form-fun () + #-x86 (progn ,form) ;; no declarations are accepted + ;; Need to catch FP errors here! + #+x86 (multiple-value-prog1 ,form (float-wait))) + ,@(reverse local-funs)) + (declare (optimize (sb-c::check-tag-existence 0)) + (inline ,form-fun + ,@(mapcar #'car local-funs))) + (block ,block + ,(wrap annotated-cases)))))))))) (sb-xc:defmacro ignore-errors (&rest forms) "Execute FORMS handling ERROR conditions, returning the result of the last diff -Nru sbcl-2.1.1/src/code/eval.lisp sbcl-2.1.11/src/code/eval.lisp --- sbcl-2.1.1/src/code/eval.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/eval.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,7 +11,7 @@ (in-package "SB-IMPL") -(defparameter *eval-calls* 0) ; initialized by genesis +(defparameter *eval-calls* 0) ;;;; Turns EXPR into a lambda-form we can pass to COMPILE. Returns ;;;; a secondary value of T if we must call the resulting function @@ -100,7 +100,8 @@ ;; 2002-10-24 (let* ((sb-c:*lexenv* lexenv) (sb-c::*ir1-namespace* (sb-c::make-ir1-namespace)) - (sb-c::*undefined-warnings* nil)) + (sb-c::*undefined-warnings* nil) + sb-c::*argument-mismatch-warnings*) ;; FIXME: VALUES declaration (sb-c::process-decls decls vars diff -Nru sbcl-2.1.1/src/code/external-formats/enc-basic.lisp sbcl-2.1.11/src/code/external-formats/enc-basic.lisp --- sbcl-2.1.1/src/code/external-formats/enc-basic.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/external-formats/enc-basic.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -16,7 +16,7 @@ (declaim (inline code->ascii-mapper)) (defun code->ascii-mapper (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type char-code code)) (if (> code 127) nil @@ -24,13 +24,13 @@ (declaim (inline get-ascii-bytes)) (defun get-ascii-bytes (string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range pos)) (get-latin-bytes #'code->ascii-mapper :ascii string pos)) (defun string->ascii (string sstart send null-padding) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send)) (values (string->latin% string sstart send #'get-ascii-bytes null-padding))) @@ -74,13 +74,13 @@ (declaim (inline get-latin1-bytes)) (defun get-latin1-bytes (string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range pos)) (get-latin-bytes #'identity :latin-1 string pos)) (defun string->latin1 (string sstart send null-padding) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send)) (values (string->latin% string sstart send #'get-latin1-bytes null-padding))) @@ -117,7 +117,7 @@ (declaim (inline char-len-as-utf8)) (defun char-len-as-utf8 (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (integer 0 (#.char-code-limit)) code)) (cond ((< code 0) (bug "can't happen")) ((< code #x80) 1) @@ -127,7 +127,7 @@ (t (bug "can't happen")))) (defun string->utf8 (string sstart send null-padding) - (declare (optimize (speed 3) (safety 0)) + (declare (optimize (speed 3) #.*safety-0*) (type simple-string string) (type (integer 0 1) null-padding) (type array-range sstart send)) @@ -217,7 +217,7 @@ 0 1 0))) (declare (type (simple-array (unsigned-byte 8) (#+sb-unicode 4 #-sb-unicode 2)) lexically-max)) (defun ,name (array pos end) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos end)) ;; returns the number of bytes consumed and nil if it's a @@ -334,7 +334,7 @@ `(progn (declaim (inline ,name)) (defun ,name (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes)) @@ -358,7 +358,7 @@ (let ((name (make-od-name 'utf8->string accessor))) `(progn (defun ,name (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) diff -Nru sbcl-2.1.1/src/code/external-formats/enc-cn.lisp sbcl-2.1.11/src/code/external-formats/enc-cn.lisp --- sbcl-2.1.1/src/code/external-formats/enc-cn.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/external-formats/enc-cn.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,24 +9,24 @@ mb-len-as-gbk gbk-continuation-byte-p)) (defun ucs-to-gbk (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type fixnum code)) (if (<= code #x7f) code (get-multibyte-mapper +ucs-to-gbk-table+ code))) (defun gbk-to-ucs (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type fixnum code)) (if (<= code #x7f) code (get-multibyte-mapper +gbk-to-ucs-table+ code))) (defun mb-len-as-gbk (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) code)) (if (< code #x80) 1 2)) (defun gbk-continuation-byte-p (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) code) (ignore code)) t) diff -Nru sbcl-2.1.1/src/code/external-formats/enc-ebcdic.lisp sbcl-2.1.11/src/code/external-formats/enc-ebcdic.lisp --- sbcl-2.1.1/src/code/external-formats/enc-ebcdic.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/external-formats/enc-ebcdic.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,11 +9,11 @@ (setf (aref code-to-byte-table (aref byte-to-code-table i)) i)) `(progn (defun ,byte-code-name (byte) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) byte)) (aref ,byte-to-code-table byte)) (defun ,code-byte-name (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type char-code code)) (if (> code 255) nil @@ -39,13 +39,13 @@ (declaim (inline get-ebcdic-us-bytes)) (defun get-ebcdic-us-bytes (string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range pos)) (get-latin-bytes #'code->ebcdic-us-mapper :ebcdic-us string pos)) (defun string->ebcdic-us (string sstart send null-padding) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send)) (values (string->latin% string sstart send #'get-ebcdic-us-bytes null-padding))) diff -Nru sbcl-2.1.1/src/code/external-formats/enc-jpn.lisp sbcl-2.1.11/src/code/external-formats/enc-jpn.lisp --- sbcl-2.1.1/src/code/external-formats/enc-jpn.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/external-formats/enc-jpn.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -5,26 +5,26 @@ mb-len-as-eucjp eucjp-continuation-byte-p)) (defun ucs-to-eucjp (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type fixnum code)) (if (<= code #x7F) code (get-multibyte-mapper +ucs-to-eucjp-table+ code))) (defun eucjp-to-ucs (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type fixnum code)) (if (<= code #x7F) code (get-multibyte-mapper +eucjp-to-ucs-table+ code))) (defun mb-len-as-eucjp (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) code)) (cond ((< code #x80) 1) ((or (= code #x8E) (<= #xA1 code #xFE)) 2) ((= code #x8F) 3))) (defun eucjp-continuation-byte-p (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) code)) (<= #xA1 code #xFE)) @@ -37,25 +37,25 @@ mb-len-as-sjis sjis-continuation-byte-p)) (defun ucs-to-sjis (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type fixnum code)) (if (<= code #x7F) code (get-multibyte-mapper +ucs-to-sjis-table+ code))) (defun sjis-to-ucs (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type fixnum code)) (if (<= code #x7F) code (get-multibyte-mapper +sjis-to-ucs-table+ code))) (defun mb-len-as-sjis (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) code)) (cond ((or (< code #x80) (<= #xA1 code #xDF)) 1) ((or (<= #x81 code #x9F) (<= #xE0 code #xFC)) 2))) (defun sjis-continuation-byte-p (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) code)) (or (<= #x40 code #x7E) (<= #x80 code #xFC))) diff -Nru sbcl-2.1.1/src/code/external-formats/enc-ucs.lisp sbcl-2.1.11/src/code/external-formats/enc-ucs.lisp --- sbcl-2.1.1/src/code/external-formats/enc-ucs.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/external-formats/enc-ucs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -86,7 +86,7 @@ ;;; Conversion to UCS-2{LE,BE} (declaim (inline char->ucs-2le)) (defun char->ucs-2le (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest)) (let ((code (char-code char))) (if (< code #x10000) @@ -103,7 +103,7 @@ (declaim (inline char->ucs-2be)) (defun char->ucs-2be (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest)) (let ((code (char-code char))) (if (< code #x10000) @@ -119,7 +119,7 @@ (vector-push-extend (aref replacement i) dest)))))) (defun string->ucs-2le (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 2 (+ additional-space (- send sstart))) @@ -132,7 +132,7 @@ (coerce array '(simple-array (unsigned-byte 8) (*))))) (defun string->ucs-2be (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 2 (+ additional-space (- send sstart))) @@ -163,7 +163,7 @@ (name-be (make-od-name 'simple-get-ucs-2be-char accessor))) `(progn (defun ,name-le (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes) @@ -178,7 +178,7 @@ (declare (inline cref)) (code-char (dpb (cref 1) (byte 8 8) (cref 0)))))) (defun ,name-be (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes) @@ -199,7 +199,7 @@ (name-be (make-od-name 'ucs-2be->string accessor))) `(progn (defun ,name-le (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) @@ -216,7 +216,7 @@ (incf pos bytes))) string)) (defun ,name-be (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) @@ -259,7 +259,7 @@ (declaim (inline char->ucs-4le)) (defun char->ucs-4le (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest) (ignore string pos)) (let ((code (char-code char))) @@ -274,7 +274,7 @@ (declaim (inline char->ucs-4be)) (defun char->ucs-4be (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest) (ignore string pos)) (let ((code (char-code char))) @@ -288,7 +288,7 @@ (add-byte (ldb (byte 8 0) code))))) (defun string->ucs-4le (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 4 (+ additional-space (- send sstart))) @@ -301,7 +301,7 @@ (coerce array '(simple-array (unsigned-byte 8) (*))))) (defun string->ucs-4be (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 4 (+ additional-space (- send sstart))) @@ -332,7 +332,7 @@ (name-be (make-od-name 'simple-get-ucs-4be-char accessor))) `(progn (defun ,name-le (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes)) @@ -352,7 +352,7 @@ (decoding-error array pos (+ pos bytes) :ucs-4le 'octet-decoding-error pos)))) (defun ,name-be (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes)) @@ -372,7 +372,7 @@ 'octet-decoding-error pos))))))) (eval-when (:compile-toplevel) - (sb-xc:proclaim '(muffle-conditions compiler-note))) + (proclaim '(muffle-conditions compiler-note))) (instantiate-octets-definition define-simple-get-ucs4-character) (defmacro define-ucs-4->string (accessor type) @@ -380,7 +380,7 @@ (name-be (make-od-name 'ucs-4be->string accessor))) `(progn (defun ,name-le (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) @@ -398,7 +398,7 @@ (incf pos bytes))) string)) (defun ,name-be (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) diff -Nru sbcl-2.1.1/src/code/external-formats/enc-utf.lisp sbcl-2.1.11/src/code/external-formats/enc-utf.lisp --- sbcl-2.1.1/src/code/external-formats/enc-utf.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/external-formats/enc-utf.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -26,7 +26,7 @@ ;;; Conversion to UTF-16{LE,BE} (declaim (inline char->utf-16le)) (defun char->utf-16le (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest)) (let ((code (char-code char))) (if (utf-noncharacter-code-p code) @@ -53,7 +53,7 @@ (declaim (inline char->utf-16be)) (defun char->utf-16be (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest)) (let ((code (char-code char))) (if (utf-noncharacter-code-p code) @@ -79,7 +79,7 @@ (add-byte (ldb (byte 8 0) low))))))))) (defun string->utf-16le (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 2 (+ additional-space (- send sstart))) @@ -92,7 +92,7 @@ (coerce array '(simple-array (unsigned-byte 8) (*))))) (defun string->utf-16be (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 2 (+ additional-space (- send sstart))) @@ -157,7 +157,7 @@ (name-be (make-od-name 'simple-get-utf-16be-char accessor))) `(progn (defun ,name-le (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes) @@ -182,7 +182,7 @@ (code-char (+ #x10000 (dpb (ldb (byte 10 0) code) (byte 10 10) (ldb (byte 10 0) next))))) (code-char code)))) (defun ,name-be (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes) @@ -213,7 +213,7 @@ (name-be (make-od-name 'utf-16be->string accessor))) `(progn (defun ,name-le (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) @@ -233,7 +233,7 @@ (incf pos bytes))) string)) (defun ,name-be (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) @@ -327,7 +327,7 @@ (declaim (inline char->utf-32le)) (defun char->utf-32le (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest)) (let ((code (char-code char))) (if (utf-noncharacter-code-p code) @@ -346,7 +346,7 @@ (declaim (inline char->utf-32be)) (defun char->utf-32be (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest)) (let ((code (char-code char))) (if (utf-noncharacter-code-p code) @@ -364,7 +364,7 @@ (add-byte (ldb (byte 8 0) code)))))) (defun string->utf-32le (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 4 (+ additional-space (- send sstart))) @@ -377,7 +377,7 @@ (coerce array '(simple-array (unsigned-byte 8) (*))))) (defun string->utf-32be (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (* 4 (+ additional-space (- send sstart))) @@ -408,7 +408,7 @@ (name-be (make-od-name 'simple-get-utf-32be-char accessor))) `(progn (defun ,name-le (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes)) @@ -429,7 +429,7 @@ (decoding-error array pos (+ pos bytes) :utf-32le 'octet-decoding-error pos)))) (defun ,name-be (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 4) bytes)) @@ -457,7 +457,7 @@ (name-be (make-od-name 'utf-32be->string accessor))) `(progn (defun ,name-le (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) @@ -475,7 +475,7 @@ (incf pos bytes))) string)) (defun ,name-be (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) diff -Nru sbcl-2.1.1/src/code/external-formats/mb-util.lisp sbcl-2.1.11/src/code/external-formats/mb-util.lisp --- sbcl-2.1.1/src/code/external-formats/mb-util.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/external-formats/mb-util.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -10,7 +10,7 @@ #'equalp))) (defun get-multibyte-mapper (table code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array * (* 2)) table) (type fixnum code)) (labels ((recur (start end) @@ -42,7 +42,7 @@ `(progn ;;(declaim (inline ,name)) (defun ,name (array pos end) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos end)) ;; returns the number of bytes consumed and nil if it's a @@ -113,7 +113,7 @@ `(progn (declaim (inline ,name)) (defun ,name (array pos bytes) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range pos) (type (integer 1 3) bytes)) @@ -140,7 +140,7 @@ (make-od-name-list 'simple-get format 'char accessor))) `(progn (defun ,name (array astart aend) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend)) (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) @@ -165,7 +165,7 @@ (declaim (inline mb-char-len)) (defun mb-char-len (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type fixnum code)) (cond ((< code 0) (bug "can't happen")) ((< code #x100) 1) @@ -196,7 +196,7 @@ (declaim (inline ,char->mb)) (defun ,char->mb (char dest string pos) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (array (unsigned-byte 8) (*)) dest)) (let ((code (,ucs-to-mb (char-code char)))) (if code @@ -218,7 +218,7 @@ (encoding-error ,format string pos)))) (defun ,string->mb (string sstart send additional-space) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type array-range sstart send additional-space)) (let ((array (make-array (+ additional-space (- send sstart)) diff -Nru sbcl-2.1.1/src/code/fdefinition.lisp sbcl-2.1.11/src/code/fdefinition.lisp --- sbcl-2.1.1/src/code/fdefinition.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/fdefinition.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -16,7 +16,7 @@ ;; This variable properly belongs in 'target-hash-table', ;; but it's compiled after this file is. -(!define-load-time-global *user-hash-table-tests* nil) +(define-load-time-global *user-hash-table-tests* nil) ;;;; fdefinition (fdefn) objects @@ -27,10 +27,8 @@ (let ((fdefn (truly-the (values fdefn &optional) (sb-vm::alloc-immobile-fdefn)))) (sb-vm::%set-fdefn-name fdefn name) - ;; Return the result of FDEFN-MAKUNBOUND because it (strangely) returns its - ;; argument. Using FDEFN as the value of this function, as if we didn't know - ;; that FDEFN-MAKUNBOUND did that, would cause a redundant register move. - (truly-the fdefn (fdefn-makunbound fdefn)))) + (fdefn-makunbound fdefn) + fdefn)) (defun (setf fdefn-fun) (fun fdefn) (declare (type function fun) @@ -39,14 +37,14 @@ #+immobile-code (sb-vm::%set-fdefn-fun fdefn fun) #-immobile-code (setf (fdefn-fun fdefn) fun)) -;; Given Info-Vector VECT, return the fdefn that it contains for its root name, +;; Given PACKED-INFO, return the fdefn that it contains for its root name, ;; or nil if there is no value. NIL input is acceptable and will return NIL. ;; (see src/compiler/info-vector for more details) -(declaim (inline info-vector-fdefn)) -(defun info-vector-fdefn (vect) - (when vect - ;; This is safe: Info-Vector invariant requires that it have length >= 1. - (let ((word (the fixnum (svref vect 0)))) +(declaim (inline packed-info-fdefn)) +(defun packed-info-fdefn (packed-info) + (when packed-info + ;; This is safe: PACKED-INFO invariant requires that it have length >= 1. + (let ((word (the fixnum (%info-ref packed-info 0)))) ;; Test that the first info-number is +fdefn-info-num+ and its n-infos ;; field is nonzero. These conditions can be tested simultaneously ;; using a SIMD-in-a-register idea. The low 6 bits must be nonzero @@ -54,16 +52,15 @@ ;; as a 12-bit unsigned integer it must be >= #b111111000001 (when (>= (ldb (byte (* info-number-bits 2) 0) word) (1+ (ash +fdefn-info-num+ info-number-bits))) - ;; DATA-REF-WITH-OFFSET doesn't know the info-vector length invariant, - ;; so depite (safety 0) eliding bounds check, FOLD-INDEX-ADDRESSING - ;; wasn't kicking in without (TRULY-THE (INTEGER 1 *)). - (aref vect (1- (truly-the (integer 1 *) (length vect)))))))) + (%info-ref packed-info + (1- (truly-the (integer 1 *) + (packed-info-len packed-info)))))))) ;; Return SYMBOL's fdefinition, if any, or NIL. SYMBOL must already ;; have been verified to be a symbol by the caller. (defun symbol-fdefn (symbol) (declare (optimize (safety 0))) - (info-vector-fdefn (symbol-info-vector symbol))) + (packed-info-fdefn (symbol-dbinfo symbol))) ;; Return the fdefn object for NAME, or NIL if there is no fdefn. ;; Signal an error if name isn't valid. @@ -82,7 +79,7 @@ (return-from find-fdefn it)) :simple (progn - (awhen (symbol-info-vector key1) + (awhen (symbol-dbinfo key1) (multiple-value-bind (data-idx descriptor-idx field-idx) (info-find-aux-key/packed it key2) (declare (type index descriptor-idx) @@ -95,7 +92,7 @@ (when (eql (packed-info-field it descriptor-idx field-idx) +fdefn-info-num+) (return-from find-fdefn - (aref it (1- (the index data-idx)))))))) + (%info-ref it (1- (the index data-idx)))))))) (when (eq key1 'setf) ; bypass the legality test (return-from find-fdefn nil)))) (legal-fun-name-or-type-error name)) @@ -131,7 +128,7 @@ ;; if we already know that FUNCTION is a function. ;; It will signal a type error if not, which is the right thing to do anyway. ;; (this isn't quite a true predicate) - (and (= (fun-subtype function) sb-vm:closure-widetag) + (and (= (%fun-pointer-widetag function) sb-vm:closure-widetag) ;; This test needs to reference the name of any macro, but in order for ;; cold-init to work, the macro has to be defined first. ;; So pick DX-LET, as it's in primordial-extensions. @@ -223,8 +220,11 @@ (symbol (%coerce-name-to-fun callable symbol-fdefn t)))) ;;; Behaves just like %COERCE-CALLABLE-TO-FUN but has an ir2-convert optimizer. -(%defun '%coerce-callable-for-call - #'%coerce-callable-to-fun) +(defun %coerce-callable-for-call (callable) + (declare (explicit-check)) + (etypecase callable + (function callable) + (symbol (%coerce-name-to-fun callable symbol-fdefn t)))) ;;;; definition encapsulation @@ -398,13 +398,14 @@ ;; with this. (when (and (symbolp name) (fboundp name)) (let ((old (symbol-function name))) - (dolist (spec *user-hash-table-tests*) - (cond ((eq old (second spec)) - ;; test-function - (setf (second spec) new-value)) - ((eq old (third spec)) - ;; hash-function - (setf (third spec) new-value)))))) + (when (boundp '*setf-fdefinition-hook*) + (dolist (spec *user-hash-table-tests*) + (cond ((eq old (second spec)) + ;; test-function + (setf (second spec) new-value)) + ((eq old (third spec)) + ;; hash-function + (setf (third spec) new-value))))))) ;; FIXME: This is a good hook to have, but we should probably ;; reserve it for users. @@ -435,8 +436,7 @@ (defun fboundp (name) "Return true if name has a global function definition." (declare (explicit-check)) - (let ((fdefn (find-fdefn name))) - (and fdefn (fdefn-fun fdefn) t))) + (awhen (find-fdefn name) (fdefn-fun it))) (defun fmakunbound (name) "Make NAME have no global function definition." diff -Nru sbcl-2.1.1/src/code/fd-stream.lisp sbcl-2.1.11/src/code/fd-stream.lisp --- sbcl-2.1.1/src/code/fd-stream.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/fd-stream.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -2308,6 +2308,10 @@ namestring err "~@" namestring original)))) +(defun file-exist-p (path) + #-win32 (sb-unix:unix-access path sb-unix:f_ok) + #+win32 (/= (sb-win32:get-file-attributes path) sb-win32::invalid-file-attributes)) + (defun %open-error (pathname errno if-exists if-does-not-exist) (flet ((signal-it (&rest arguments) (apply #'file-perror pathname errno arguments))) @@ -2394,7 +2398,7 @@ (physical (native-namestring (physicalize-pathname pathname) :as-file t)) ;; One call to access() is reasonable. 40 calls to lstat() is not. ;; So DO NOT CALL TRUENAME HERE. - (existsp (sb-unix:unix-access physical sb-unix:f_ok)) + (existsp (file-exist-p physical)) ;; Leave NAMESTRING as NIL if nonexistent and not creating a file. (namestring (when (or existsp (or (not input) @@ -2554,134 +2558,6 @@ (when new-if-does-not-exist (setf if-does-not-exist new-if-does-not-exist if-does-not-exist-given t))))))))) - -;;;; initialization - -;;; the stream connected to the controlling terminal, or NIL if there is none -(defvar *tty*) - -;;; the stream connected to the standard input (file descriptor 0) -(defvar *stdin*) - -;;; the stream connected to the standard output (file descriptor 1) -(defvar *stdout*) - -;;; the stream connected to the standard error output (file descriptor 2) -(defvar *stderr*) - -;;; This is called when the cold load is first started up, and may also -;;; be called in an attempt to recover from nested errors. -(defun stream-cold-init-or-reset () - (stream-reinit) - (setf *terminal-io* (make-synonym-stream '*tty*)) - (setf *standard-output* (make-synonym-stream '*stdout*)) - (setf *standard-input* (make-synonym-stream '*stdin*)) - (setf *error-output* (make-synonym-stream '*stderr*)) - (setf *query-io* (make-synonym-stream '*terminal-io*)) - (setf *debug-io* *query-io*) - (setf *trace-output* *standard-output*) - (values)) - -(defun stream-deinit () - (setq *tty* nil *stdin* nil *stdout* nil *stderr* nil) - ;; Unbind to make sure we're not accidently dealing with it - ;; before we're ready (or after we think it's been deinitialized). - ;; This uses the internal %MAKUNBOUND because the CL: function would - ;; rightly complain that *AVAILABLE-BUFFERS* is proclaimed always bound. - (%makunbound '*available-buffers*)) - -(defvar *streams-closed-by-slad*) - -(defun restore-fd-streams () - (loop for (stream in bin n-bin out bout sout misc) in *streams-closed-by-slad* - do - (setf (ansi-stream-in stream) in) - (setf (ansi-stream-bin stream) bin) - (setf (ansi-stream-n-bin stream) n-bin) - (setf (ansi-stream-out stream) out) - (setf (ansi-stream-bout stream) bout) - (setf (ansi-stream-sout stream) sout) - (setf (ansi-stream-misc stream) misc))) - -(defun stdstream-external-format (fd) - #-win32 (declare (ignore fd)) - (let* ((keyword (cond #+(and win32 sb-unicode) - ((sb-win32::console-handle-p fd) - :ucs-2) - (t - (default-external-format)))) - (ef (get-external-format keyword)) - (replacement (ef-default-replacement-character ef))) - `(,keyword :replacement ,replacement))) - -;;; This is called whenever a saved core is restarted. -(defun stream-reinit (&optional init-buffers-p) - (when init-buffers-p - ;; Use the internal %BOUNDP for similar reason to that cited above- - ;; BOUNDP on a known global transforms to the constant T. - (aver (not (%boundp '*available-buffers*))) - (setf *available-buffers* nil)) - (%with-output-to-string (*error-output*) - (multiple-value-bind (in out err) - #-win32 (values 0 1 2) - #+win32 (sb-win32::get-std-handles) - (labels (#+win32 - (nul-stream (name inputp outputp) - (let ((nul-handle - (cond - ((and inputp outputp) - (sb-win32:unixlike-open "NUL" sb-unix:o_rdwr)) - (inputp - (sb-win32:unixlike-open "NUL" sb-unix:o_rdonly)) - (outputp - (sb-win32:unixlike-open "NUL" sb-unix:o_wronly)) - (t - ;; Not quite sure what to do in this case. - nil)))) - (make-fd-stream - nul-handle - :name name - :input inputp - :output outputp - :buffering :line - :element-type :default - :serve-events inputp - :auto-close t - :external-format (stdstream-external-format nul-handle)))) - (stdio-stream (handle name inputp outputp) - (cond - #+win32 - ((null handle) - ;; If no actual handle was present, create a stream to NUL - (nul-stream name inputp outputp)) - (t - (make-fd-stream - handle - :name name - :input inputp - :output outputp - :buffering :line - :element-type :default - :serve-events inputp - :external-format (stdstream-external-format handle)))))) - (setf *stdin* (stdio-stream in "standard input" t nil) - *stdout* (stdio-stream out "standard output" nil t) - *stderr* (stdio-stream err "standard error" nil t)))) - #+win32 - (setf *tty* (make-two-way-stream *stdin* *stdout*)) - #-win32 - (let ((tty (sb-unix:unix-open "/dev/tty" sb-unix:o_rdwr #o666))) - (setf *tty* - (if tty - (make-fd-stream tty :name "the terminal" - :input t :output t :buffering :line - :external-format (stdstream-external-format tty) - :serve-events t - :auto-close t) - (make-two-way-stream *stdin* *stdout*)))) - (princ (get-output-stream-string *error-output*) *stderr*)) - (values)) - ;;;; miscellany ;;; the Unix way to beep @@ -2734,7 +2610,9 @@ (t ; call next method (fd-stream-misc-routine stream operation arg1)))) -(!define-load-time-global *!cold-stderr-buf* " ") +;;;; machinery to make string printing work early + +(define-load-time-global *!cold-stderr-buf* (make-string 1 :element-type 'base-char :initial-element #\Space)) (declaim (type (simple-base-string 1) *!cold-stderr-buf*)) (defun !make-cold-stderr-stream () @@ -2764,3 +2642,9 @@ (stream-misc-case (operation :default nil) (:charpos ; impart just enough smarts to make FRESH-LINE dtrt (if (eql (char *!cold-stderr-buf* 0) #\newline) 0 1))))))) + +(defun !cold-stream-init () + (setq *!cold-stderr-buf* (make-string 1 :element-type 'base-char :initial-element #\Space) + *error-output* (!make-cold-stderr-stream) + *standard-output* *error-output* + *trace-output* *error-output*)) diff -Nru sbcl-2.1.1/src/code/filesys.lisp sbcl-2.1.11/src/code/filesys.lisp --- sbcl-2.1.1/src/code/filesys.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/filesys.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -266,20 +266,25 @@ :newest))))) -;;;; Grabbing the kind of file when we have a namestring. -(defun native-file-kind (namestring) +;;;; Grabbing the kind of file when we have a native-namestring. +(defun native-file-kind (namestring &optional resolve-symlinks) + #+win32 (declare (ignore resolve-symlinks)) + #+win32 (nth-value 1 (sb-win32::native-probe-file-name namestring)) + #-win32 (multiple-value-bind (existsp errno ino mode) - #-win32 - (sb-unix:unix-lstat namestring) - #+win32 - (sb-unix:unix-stat namestring) + ;; Note that when resolve-symlinks is true, we'll return NIL if + ;; there are circular and dangling symlinks anywhere in the + ;; path. That's different than what our TRUENAME does; this is + ;; intended as an efficient internal routine. + (if resolve-symlinks + (sb-unix:unix-stat namestring) + (sb-unix:unix-lstat namestring)) (declare (ignore errno ino)) (when existsp (let ((ifmt (logand mode sb-unix:s-ifmt))) (case ifmt (#.sb-unix:s-ifreg :file) (#.sb-unix:s-ifdir :directory) - #-win32 (#.sb-unix:s-iflnk :symlink) (t :special)))))) @@ -1240,6 +1245,15 @@ (null (pathname-name pathname)) (null (pathname-type pathname)))) +;; FIXME: repeatedly poking at the file system ought to be +;; unnecessary, and walking the directory hierarchy from the top down +;; is probably a waste of effort in most cases. If we can trust mkdir +;; returning ENOENT and EEXIST always and only where it's supposed to, +;; we could get this down to two syscalls in the optimal success case +;; case, one in the pessimal failure case, and no worse than this in a +;; hypothetical average. (It looks like we inherited this approach +;; from CMUCL; maybe some ancient Unix's mkdir errno values weren't +;; reliable?) (defun ensure-directories-exist (pathspec &key verbose (mode #o777)) "Test whether the directories containing the specified file actually exist, and attempt to create them if they do not. @@ -1249,37 +1263,37 @@ (created-p nil)) (when (wild-pathname-p pathname) (sb-kernel::%file-error pathspec "bad place for a wild pathname")) - (let* ((dir (pathname-directory pathname)) - (*default-pathname-defaults* - (make-pathname :directory dir :device (pathname-device pathname))) - (dev (pathname-device pathname))) + (let* ((host (pathname-host pathname)) + (dir (pathname-directory pathname)) + (dev (pathname-device pathname))) (loop for i from (case dev (:unc 3) (otherwise 2)) upto (length dir) do (let* ((newpath (make-pathname - :host (pathname-host pathname) + :host host :device dev :directory (subseq dir 0 i))) - (probed (probe-file newpath))) - (unless (directory-pathname-p probed) - (let ((namestring (coerce (native-namestring newpath) - 'string))) - (when verbose - (format *standard-output* - "~&creating directory: ~A~%" - namestring)) - (sb-unix:unix-mkdir namestring mode) - (unless (directory-pathname-p (probe-file newpath)) + (namestring (coerce (native-namestring newpath :as-file t) + 'string)) + (kind (native-file-kind namestring t))) + (unless (eq :directory kind) + (when verbose + (format *standard-output* + "~&creating directory: ~A~%" + namestring)) + (sb-unix:unix-mkdir namestring mode) + (let ((newkind (native-file-kind namestring t))) + (unless (eq :directory newkind) (restart-case (sb-kernel::%file-error pathspec "Can't create directory ~A~:[~;,~%a file with ~ the same name already exists.~]" namestring - (and probed (not (directory-pathname-p probed)))) + (and kind (not (eq :directory newkind)))) (retry () :report "Retry directory creation." (ensure-directories-exist - pathspec :verbose verbose :mode mode)))) - (setf created-p t))))) + pathspec :verbose verbose :mode mode))))) + (setf created-p t)))) (values pathspec created-p)))) diff -Nru sbcl-2.1.1/src/code/final.lisp sbcl-2.1.11/src/code/final.lisp --- sbcl-2.1.1/src/code/final.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/final.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -25,7 +25,7 @@ (defmacro finalizer-max-id (store) `(elt ,store 2)) (defun make-finalizer-store (array-length) - (let* ((v (make-array (the index array-length))) + (let* ((v (make-array (the index array-length) :initial-element 0)) (ht (make-system-hash-table :test 'eq :weakness :key :synchronized nil :finalizer t))) ;; The recycle bin has a dummy item in front so that the simple-vector @@ -311,11 +311,15 @@ ;;; FINALIZER-THREAD-{START,STOP}, S-L-A-D, SB-POSIX:FORK (defun finalizer-thread-start () (with-system-mutex (sb-thread::*make-thread-lock*) + #+(and unix sb-safepoint) + (sb-thread::make-system-thread "sigwait" + #'sb-unix::signal-handler-loop + nil 'sb-unix::*sighandler-thread*) (aver (not *finalizer-thread*)) (setf finalizer-thread-runflag 1) (setq *finalizer-thread* :start) (let ((thread - (sb-thread::make-ephemeral-thread + (sb-thread::make-system-thread "finalizer" (lambda () (setf *finalizer-thread* sb-thread:*current-thread*) @@ -323,7 +327,7 @@ (alien-funcall (extern-alien "finalizer_thread_wait" (function void))) (when (zerop finalizer-thread-runflag) (return))) (setq *finalizer-thread* nil)) - nil))) + nil nil))) ;; Don't return from this function until *FINALIZER-THREAD* has a good value, ;; but don't set it to a thread if the thread was not created, or exited already. (cas *finalizer-thread* :start thread)))) @@ -331,6 +335,14 @@ ;;; You should almost always invoke this with *MAKE-THREAD-LOCK* held. ;;; Some tests violate that, but they know what they're doing. (defun finalizer-thread-stop () + #+(and unix sb-safepoint) + (let ((thread sb-unix::*sighandler-thread*)) + (aver (sb-thread::thread-p thread)) + (setq sb-unix::*sighandler-thread* nil) + ;; This kill causes the thread's sigwait() syscall to return normally + ;; and then not invoke any handler. + (sb-unix:pthread-kill (sb-thread::thread-os-thread thread) sb-unix:sigterm) + (sb-thread:join-thread thread)) (let ((thread *finalizer-thread*)) (aver (sb-thread::thread-p thread)) (alien-funcall (extern-alien "finalizer_thread_stop" (function void))) diff -Nru sbcl-2.1.1/src/code/float-inf-nan.lisp sbcl-2.1.11/src/code/float-inf-nan.lisp --- sbcl-2.1.1/src/code/float-inf-nan.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/float-inf-nan.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,13 +18,39 @@ (declaim (maybe-inline float-denormalized-p float-infinity-p float-nan-p float-trapping-nan-p)) +(defmacro sfloat-bits-subnormalp (bits) + `(zerop (ldb sb-vm:single-float-exponent-byte ,bits))) +#-64-bit +(defmacro dfloat-high-bits-subnormalp (bits) + `(zerop (ldb sb-vm:double-float-exponent-byte ,bits))) +#+64-bit +(progn +(defmacro dfloat-exponent-from-bits (bits) + `(ldb (byte ,(byte-size sb-vm:double-float-exponent-byte) + ,(+ 32 (byte-position sb-vm:double-float-exponent-byte))) + ,bits)) +(defmacro dfloat-bits-subnormalp (bits) + `(zerop (dfloat-exponent-from-bits ,bits)))) + (defun float-denormalized-p (x) "Return true if the float X is denormalized." + (declare (explicit-check)) (number-dispatch ((x float)) ((single-float) + #+64-bit + (let ((bits (single-float-bits x))) + (and (ldb-test (byte 31 0) bits) ; is nonzero (disregard the sign bit) + (sfloat-bits-subnormalp bits))) + #-64-bit (and (zerop (ldb sb-vm:single-float-exponent-byte (single-float-bits x))) (not (zerop x)))) ((double-float) + #+64-bit + (let ((bits (double-float-bits x))) + ;; is nonzero after shifting out the sign bit + (and (not (zerop (logand (ash bits 1) most-positive-word))) + (dfloat-bits-subnormalp bits))) + #-64-bit (and (zerop (ldb sb-vm:double-float-exponent-byte (double-float-high-bits x))) (not (zerop x)))) diff -Nru sbcl-2.1.1/src/code/float.lisp sbcl-2.1.11/src/code/float.lisp --- sbcl-2.1.1/src/code/float.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/float.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -25,26 +25,27 @@ "Return a non-negative number of significant digits in its float argument. Will be less than FLOAT-DIGITS if denormalized or zero." (declare (explicit-check)) - (macrolet ((frob (digits bias decode) - `(cond ((zerop f) 0) - ((float-denormalized-p f) - (multiple-value-bind (ignore exp) (,decode f) - (declare (ignore ignore)) - (truly-the fixnum - (+ ,digits (1- ,digits) ,bias exp)))) - (t - ,digits)))) - (number-dispatch ((f float)) - ((single-float) - (frob sb-vm:single-float-digits sb-vm:single-float-bias - integer-decode-single-denorm)) - ((double-float) - (frob sb-vm:double-float-digits sb-vm:double-float-bias - integer-decode-double-denorm)) - #+long-float - ((long-float) - (frob sb-vm:long-float-digits sb-vm:long-float-bias - integer-decode-long-denorm))))) + (integer-length + (number-dispatch ((f float)) + ((single-float) + (let ((bits (single-float-bits f))) + (if (sfloat-bits-subnormalp bits) + (ldb sb-vm:single-float-significand-byte bits) + (return-from float-precision sb-vm:single-float-digits)))) + ((double-float) + #+64-bit + (let ((bits (double-float-bits f))) + (if (dfloat-bits-subnormalp bits) + (ldb (byte 52 0) bits) + (return-from float-precision sb-vm:double-float-digits))) + #-64-bit + (let ((high (double-float-high-bits f))) + (if (not (dfloat-high-bits-subnormalp high)) + (return-from float-precision sb-vm:double-float-digits) + (let ((n (integer-length (ldb sb-vm:double-float-significand-byte high)))) + (if (/= 0 n) + (return-from float-precision (+ n 32)) + (double-float-low-bits f))))))))) (defun float-sign (float1 &optional (float2 (float 1 float1))) "Return a floating-point number that has the same sign as @@ -108,168 +109,66 @@ (declaim (maybe-inline integer-decode-single-float integer-decode-double-float)) -;;; Handle the denormalized case of INTEGER-DECODE-FLOAT for SINGLE-FLOAT. -(defun integer-decode-single-denorm (x) - (declare (type single-float x)) - (let* ((bits (single-float-bits x)) - (sig (ash (ldb sb-vm:single-float-significand-byte bits) 1)) - (extra-bias 0)) - (declare (type (unsigned-byte 24) sig) - (type (integer 0 23) extra-bias)) - (loop - (unless (zerop (logand sig sb-vm:single-float-hidden-bit)) - (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values sig - (- (- sb-vm:single-float-bias) - sb-vm:single-float-digits - extra-bias) - (if (minusp bits) -1 1)))) +;;; binary point is to the left of the 23 represented mantissa bits, +;;; and normal exponent min is -126, so -149 is the effective exponent +;;; of a subnormal in common-lisp terms. +(defconstant subnormal-sfloat-exponent -149) +;; binary point is to the left of the 52 represented mantissa bits, +;; and normal exponent min is -1022, so -1074 is the effective exponent. +(defconstant subnormal-dfloat-exponent -1074) ;;; Handle the single-float case of INTEGER-DECODE-FLOAT. If an infinity or -;;; NaN, error. If a denorm, call i-d-s-DENORM to handle it. +;;; NaN, error. (defun integer-decode-single-float (x) (declare (single-float x)) (let* ((bits (single-float-bits x)) + (frac (ldb sb-vm:single-float-significand-byte bits)) + (sign (if (minusp bits) -1 1)) (exp (ldb sb-vm:single-float-exponent-byte bits))) - (cond ((zerop (ldb (byte 31 0) bits)) - (values 0 0 (if (minusp bits) -1 1))) - ((< exp sb-vm:single-float-normal-exponent-min) - (integer-decode-single-denorm x)) + (cond ((= exp 0) + (values frac (if (= frac 0) 0 subnormal-sfloat-exponent) sign)) ((> exp sb-vm:single-float-normal-exponent-max) (error float-decoding-error x)) (t - (values (logior (ldb sb-vm:single-float-significand-byte bits) - sb-vm:single-float-hidden-bit) + (values (logior sb-vm:single-float-hidden-bit frac) (- exp sb-vm:single-float-bias sb-vm:single-float-digits) - (if (minusp bits) -1 1)))))) - -;;; like INTEGER-DECODE-SINGLE-DENORM, only doubly so -(defun integer-decode-double-denorm (x) - (declare (type double-float x)) - (let* ((high-bits (double-float-high-bits x)) - (sig-high (ldb sb-vm:double-float-significand-byte high-bits)) - (low-bits (double-float-low-bits x)) - (sign (if (minusp high-bits) -1 1)) - (biased (- (- sb-vm:double-float-bias) sb-vm:double-float-digits))) - (if (zerop sig-high) - (let ((sig low-bits) - (extra-bias (- sb-vm:double-float-digits 33)) - (bit (ash 1 31))) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig bit)) (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (ash sig (- sb-vm:double-float-digits 32)) - (truly-the fixnum (- biased extra-bias)) - sign)) - (let ((sig (ash sig-high 1)) - (extra-bias 0)) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig sb-vm:double-float-hidden-bit)) - (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) - (truly-the fixnum (- biased extra-bias)) - sign))))) + sign))))) ;;; like INTEGER-DECODE-SINGLE-FLOAT, only doubly so (defun integer-decode-double-float (x) (declare (double-float x)) #-64-bit ; treat high and low bits separately until the end (let* ((hi (double-float-high-bits x)) + (sign (if (minusp hi) -1 1)) (lo (double-float-low-bits x)) + (mantissa (logior (ash (ldb sb-vm:double-float-significand-byte hi) 32) lo)) (exp (ldb sb-vm:double-float-exponent-byte hi))) (cond ((zerop (logior (ldb (byte 31 0) hi) lo)) - (values 0 0 (if (minusp hi) -1 1))) + (values 0 0 sign)) ((< exp sb-vm:double-float-normal-exponent-min) - (integer-decode-double-denorm x)) + (values mantissa subnormal-dfloat-exponent sign)) ((> exp sb-vm:double-float-normal-exponent-max) (error float-decoding-error x)) (t - (values (logior (ash (logior (ldb sb-vm:double-float-significand-byte hi) - sb-vm:double-float-hidden-bit) - 32) - lo) + ;; DOUBLE-FLOAT-HIDDEN-BIT is nonsense. It's 20 because it's the index + ;; within the high half. It should be an index within the entire fraction. + ;; If you want to manipulate the fraction as two 4-byte parts, that's on you. + (values (logior (ash sb-vm:double-float-hidden-bit 32) mantissa) (- exp sb-vm:double-float-bias sb-vm:double-float-digits) - (if (minusp hi) -1 1))))) + sign)))) #+64-bit ; don't split the high and low bits (let* ((bits (double-float-bits x)) - ;; It's unfortunate that the implied meaning of EXPONENT-BYTE and - ;; SIGNIFICAND-BYTE for double-floats assumes refererence to the high half - ;; and not the entire word. Because knowledge of the splitup is imparted here - ;; and elsewhere such as SB-BIGNUM:DOUBLE-FLOAT-FROM-BITS, it isn't really - ;; up to the backend parms to impart meaning, appearances to the contrary. - (exp (ldb (byte (byte-size sb-vm:double-float-exponent-byte) - (+ 32 (byte-position sb-vm:double-float-exponent-byte))) - bits))) - (cond ((zerop (ldb (byte 63 0) bits)) - (values 0 0 (if (minusp bits) -1 1))) - ((< exp sb-vm:double-float-normal-exponent-min) - (integer-decode-double-denorm x)) + (frac (ldb (byte 52 0) bits)) + (sign (if (minusp bits) -1 1)) + (exp (dfloat-exponent-from-bits bits))) + (cond ((= exp 0) + (values frac (if (= frac 0) 0 subnormal-dfloat-exponent) sign)) ((> exp sb-vm:double-float-normal-exponent-max) (error float-decoding-error x)) (t - ;; the count of digits [sic] includes a hidden bit - (values (logior (ldb (byte (1- sb-vm:double-float-digits) 0) bits) - (ash sb-vm:double-float-hidden-bit 32)) + (values (logior (ash sb-vm:double-float-hidden-bit 32) frac) (- exp sb-vm:double-float-bias sb-vm:double-float-digits) - (if (minusp bits) -1 1)))))) - -#+(and long-float x86) -(defun integer-decode-long-denorm (x) - (declare (type long-float x)) - (let* ((high-bits (long-float-high-bits (abs x))) - (sig-high (ldb sb-vm:long-float-significand-byte high-bits)) - (low-bits (long-float-low-bits x)) - (sign (if (minusp (float-sign x)) -1 1)) - (biased (- (- sb-vm:long-float-bias) sb-vm:long-float-digits))) - (if (zerop sig-high) - (let ((sig low-bits) - (extra-bias (- sb-vm:long-float-digits 33)) - (bit (ash 1 31))) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig bit)) (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (ash sig (- sb-vm:long-float-digits 32)) - (truly-the fixnum (- biased extra-bias)) - sign)) - (let ((sig (ash sig-high 1)) - (extra-bias 0)) - (declare (type (unsigned-byte 32) sig) (fixnum extra-bias)) - (loop - (unless (zerop (logand sig sb-vm:long-float-hidden-bit)) - (return)) - (setq sig (ash sig 1)) - (incf extra-bias)) - (values (logior (ash sig 32) (ash low-bits (1- extra-bias))) - (truly-the fixnum (- biased extra-bias)) - sign))))) - -#+(and long-float x86) -(defun integer-decode-long-float (x) - (declare (long-float x)) - (let* ((hi (long-float-high-bits x)) - (lo (long-float-low-bits x)) - (exp-bits (long-float-exp-bits x)) - (exp (ldb sb-vm:long-float-exponent-byte exp-bits)) - (sign (if (minusp exp-bits) -1 1)) - (biased (- exp sb-vm:long-float-bias sb-vm:long-float-digits))) - (declare (fixnum biased)) - (cond ((and (zerop exp) (zerop hi) (zerop lo)) - (values 0 biased sign)) - ((< exp sb-vm:long-float-normal-exponent-min) - (integer-decode-long-denorm x)) - ((> exp sb-vm:long-float-normal-exponent-max) - (error float-decoding-error x)) - (t - (values (logior (ash hi 32) lo) biased sign))))) + sign))))) ;;; Dispatch to the correct type-specific i-d-f function. (defun integer-decode-float (x) @@ -285,113 +184,71 @@ ((single-float) (integer-decode-single-float x)) ((double-float) - (integer-decode-double-float x)) - #+long-float - ((long-float) - (integer-decode-long-float x)))) - -(declaim (maybe-inline decode-single-float decode-double-float)) - -;;; Handle the denormalized case of DECODE-SINGLE-FLOAT. We call -;;; INTEGER-DECODE-SINGLE-DENORM and then make the result into a float. -(defun decode-single-denorm (x) - (declare (type single-float x)) - (multiple-value-bind (sig exp sign) (integer-decode-single-denorm x) - (values (make-single-float - (dpb sig sb-vm:single-float-significand-byte - (dpb sb-vm:single-float-bias - sb-vm:single-float-exponent-byte - 0))) - (truly-the fixnum (+ exp sb-vm:single-float-digits)) - (float sign x)))) + (integer-decode-double-float x)))) ;;; Handle the single-float case of DECODE-FLOAT. If an infinity or NaN, -;;; error. If a denorm, call d-s-DENORM to handle it. +;;; error. For subnormals, we left-align the significant bits into a field +;;; that is FLOAT-DIGITS wide, and decrease the exponent. (defun decode-single-float (x) (declare (single-float x)) - (let* ((bits (ldb (byte 31 0) (single-float-bits x))) ; unset the sign bit - (exp (ldb sb-vm:single-float-exponent-byte bits)) - (sign (float-sign x))) - (cond ((zerop bits) - (values $0.0f0 0 sign)) - ((< exp sb-vm:single-float-normal-exponent-min) - (decode-single-denorm x)) - ((> exp sb-vm:single-float-normal-exponent-max) - (error float-decoding-error x)) - (t - (values (make-single-float - (dpb sb-vm:single-float-bias ; set the effective exponent to 0 - sb-vm:single-float-exponent-byte - bits)) - (truly-the single-float-exponent (- exp sb-vm:single-float-bias)) - sign))))) - -;;; like DECODE-SINGLE-DENORM, only doubly so -(defun decode-double-denorm (x) - (declare (double-float x)) - (multiple-value-bind (sig exp sign) (integer-decode-double-denorm x) - (values (make-double-float - (dpb (logand (ash sig -32) (lognot sb-vm:double-float-hidden-bit)) - sb-vm:double-float-significand-byte - (dpb sb-vm:double-float-bias - sb-vm:double-float-exponent-byte 0)) - (ldb (byte 32 0) sig)) - (truly-the fixnum (+ exp sb-vm:double-float-digits)) - (float sign x)))) - -;;; like DECODE-SINGLE-FLOAT, only doubly so + (multiple-value-bind (bits exp) + (let* ((bits (single-float-bits x)) + (biased-exp (ldb sb-vm:single-float-exponent-byte bits))) + (if (> biased-exp sb-vm:single-float-normal-exponent-max) + (error float-decoding-error x) + (let ((frac (ldb sb-vm:single-float-significand-byte bits))) + (multiple-value-bind (new-exp new-frac lisp-exponent) + (cond ((/= biased-exp 0) ; normal + ;; SINGLE-FLOAT-BIAS as the stored exponent yields + ;; an effective exponent of -1. + (values sb-vm:single-float-bias frac + (- biased-exp sb-vm:single-float-bias))) + ((= frac 0) (values 0 0 0)) + (t ; subnormal. Normalize it and unset the implied 1 bit + (let ((prec (integer-length frac))) + (values sb-vm:single-float-bias + (ldb (byte (1- sb-vm:single-float-digits) 0) + (ash frac (- sb-vm:single-float-digits prec))) + (+ subnormal-sfloat-exponent prec))))) + (values (dpb new-exp sb-vm:single-float-exponent-byte new-frac) + lisp-exponent))))) + (values (make-single-float bits) exp (float-sign x)))) + +;;; The double-float logic mostly follows the skeleton of the above code, +;;; but there is a consed bignum or two on 32-bit architectures. +;;; Consing for the sake of code clarity is worth it as far as I'm concerned. (defun decode-double-float (x) (declare (double-float x)) - (let* ((hi (double-float-high-bits x)) - (exp (ldb sb-vm:double-float-exponent-byte hi)) - (sign (float-sign x))) - (cond ((zerop x) - (values $0.0d0 0 sign)) - ((< exp sb-vm:double-float-normal-exponent-min) - (decode-double-denorm x)) - ((> exp sb-vm:double-float-normal-exponent-max) - (error float-decoding-error x)) - (t - (values (make-double-float - (dpb sb-vm:double-float-bias ; set the effective exponent to 0 - sb-vm:double-float-exponent-byte - (ldb (byte 31 0) hi)) ; unset the sign bit - (double-float-low-bits x)) - (truly-the double-float-exponent (- exp sb-vm:double-float-bias)) - sign))))) - -#+(and long-float x86) -(defun decode-long-denorm (x) - (declare (long-float x)) - (multiple-value-bind (sig exp sign) (integer-decode-long-denorm x) - (values (make-long-float sb-vm:long-float-bias (ash sig -32) - (ldb (byte 32 0) sig)) - (truly-the fixnum (+ exp sb-vm:long-float-digits)) - (float sign x)))) - -#+(and long-float x86) -(defun decode-long-float (x) - (declare (long-float x)) - (let* ((hi (long-float-high-bits x)) - (lo (long-float-low-bits x)) - (exp-bits (long-float-exp-bits x)) - (exp (ldb sb-vm:long-float-exponent-byte exp-bits)) - (sign (if (minusp exp-bits) -1l0 1l0)) - (biased (truly-the long-float-exponent - (- exp sb-vm:long-float-bias)))) - (cond ((zerop x) - (values 0.0l0 biased sign)) - ((< exp sb-vm:long-float-normal-exponent-min) - (decode-long-denorm x)) - ((> exp sb-vm:long-float-normal-exponent-max) - (error float-decoding-error x)) - (t - (values (make-long-float - (dpb sb-vm:long-float-bias sb-vm:long-float-exponent-byte - exp-bits) - hi - lo) - biased sign))))) + (multiple-value-bind (high-bits low-bits exp) + (let* #+64-bit ((bits (double-float-bits x)) + (biased-exp (dfloat-exponent-from-bits bits))) + #-64-bit ((high (double-float-high-bits x)) + (biased-exp (ldb sb-vm:double-float-exponent-byte high))) + (if (> biased-exp sb-vm:double-float-normal-exponent-max) + (error float-decoding-error x) + (let ((frac #+64-bit (ldb (byte 52 0) bits) + #-64-bit (logior (ash (ldb sb-vm:double-float-significand-byte high) 32) + (double-float-low-bits x)))) + (multiple-value-bind (new-exp new-frac lisp-exponent) + (cond ((/= biased-exp 0) ; normal + ;; DOUBLE-FLOAT-BIAS as the stored exponent yields + ;; an effective exponent of -1. + (values sb-vm:double-float-bias frac + (- biased-exp sb-vm:double-float-bias))) + ((= frac 0) (values 0 0 0)) + (t ; subnormal. Normalize it and unset the implied 1 bit + (let ((prec (integer-length frac))) + (values sb-vm:double-float-bias + (ldb (byte (1- sb-vm:double-float-digits) 0) + (ash frac (- sb-vm:double-float-digits prec))) + (+ subnormal-dfloat-exponent prec))))) + ;; Now comes the dumb part for 64-bit machines - + ;; splitting the fraction into halves for no good reason. + (values (dpb new-exp sb-vm:double-float-exponent-byte + (ldb (byte 32 32) new-frac)) + (ldb (byte 32 0) new-frac) + lisp-exponent))))) + (values (make-double-float high-bits low-bits) exp (float-sign x)))) ;;; Dispatch to the appropriate type-specific function. (defun decode-float (f) @@ -405,10 +262,7 @@ ((single-float) (decode-single-float f)) ((double-float) - (decode-double-float f)) - #+long-float - ((long-float) - (decode-long-float f)))) + (decode-double-float f)))) ;;;; SCALE-FLOAT @@ -523,11 +377,6 @@ (unsigned-byte (scale-float-maybe-overflow x exp)) ((integer * 0) (scale-float-maybe-underflow x exp)))) -#+(and x86 long-float) -(defun scale-long-float (x exp) - (declare (long-float x) (integer exp)) - (scale-float x exp)) - ;;; Dispatch to the correct type-specific scale-float function. (defun scale-float (f ex) "Return the value (* f (expt (float 2 f) ex)), but with no unnecessary loss @@ -537,10 +386,7 @@ ((single-float) (scale-single-float f ex)) ((double-float) - (scale-double-float f ex)) - #+long-float - ((long-float) - (scale-long-float f ex)))) + (scale-double-float f ex)))) ;;;; converting to/from floats diff -Nru sbcl-2.1.1/src/code/float-trap.lisp sbcl-2.1.11/src/code/float-trap.lisp --- sbcl-2.1.1/src/code/float-trap.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/float-trap.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -159,7 +159,7 @@ ;;; LEAST-NEGATIVE-SINGLE-FLOAT, so the :UNDERFLOW exceptions are ;;; disabled by default. Joe User can explicitly enable them if ;;; desired. -(defvar *saved-floating-point-modes* +(define-load-time-global *saved-floating-point-modes* '(:traps (:overflow #-(or netbsd ppc) :invalid :divide-by-zero) :rounding-mode :nearest :current-exceptions nil :accrued-exceptions nil :fast-mode nil diff -Nru sbcl-2.1.1/src/code/fop.lisp sbcl-2.1.11/src/code/fop.lisp --- sbcl-2.1.1/src/code/fop.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/fop.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -2,82 +2,6 @@ (in-package "SB-FASL") -;;; Bind STACK-VAR and PTR-VAR to the start of a subsequence of -;;; the fop stack of length COUNT, then execute BODY. -;;; Within the body, FOP-STACK-REF is used in lieu of SVREF -;;; to elide bounds checking. -(defmacro with-fop-stack (((stack-var &optional stack-expr) ptr-var count) - &body body) - `(macrolet ((fop-stack-ref (i) - `(locally - #-sb-xc-host - (declare (optimize (sb-c::insert-array-bounds-checks 0))) - (svref ,',stack-var (truly-the index ,i))))) - (let* (,@(when stack-expr - (list `(,stack-var (the simple-vector ,stack-expr)))) - (,ptr-var (truly-the index (fop-stack-pop-n ,stack-var ,count)))) - ,@body))) - -;;; Define NAME as a fasl operation, with op-code FOP-CODE. -;;; PUSHP describes what the body does to the fop stack: -;;; T - The result of the body is pushed on the fop stack. -;;; NIL - The result of the body is discarded. -;;; In either case, the body is permitted to pop the stack. -;;; -(defmacro define-fop (fop-code &rest stuff) - (multiple-value-bind (name allowp operands stack-args pushp forms) - (let ((allowp (if (eq (car stuff) :not-host) - (progn (pop stuff) (or #-sb-xc-host t)) - t))) - (destructuring-bind ((name &optional arglist (pushp t)) . forms) stuff - (aver (member pushp '(nil t))) - (multiple-value-bind (operands stack-args) - (if (atom (car arglist)) - (values nil arglist) - (ecase (caar arglist) - (:operands (values (cdar arglist) (cdr arglist))))) - (assert (<= (length operands) 3)) - (values name allowp operands stack-args pushp forms)))) - `(progn - (defun ,name (.fasl-input. ,@operands) - (declare (ignorable .fasl-input.)) - ,@(if allowp - `((macrolet - ((fasl-input () '(truly-the fasl-input .fasl-input.)) - (fasl-input-stream () '(%fasl-input-stream (fasl-input))) - (operand-stack () '(%fasl-input-stack (fasl-input))) - (skip-until () '(%fasl-input-skip-until (fasl-input)))) - ,@(if (null stack-args) - forms - (with-unique-names (stack ptr) - `((with-fop-stack ((,stack (operand-stack)) - ,ptr ,(length stack-args)) - (multiple-value-bind ,stack-args - (values ,@(loop for i below (length stack-args) - collect `(fop-stack-ref (+ ,ptr ,i)))) - ,@forms))))))) - `((declare (ignore ,@operands)) - (error ,(format nil "Not-host fop invoked: ~A" name))))) - (!%define-fop ',name ,fop-code ,(length operands) ,(if pushp 1 0))))) - -(defun !%define-fop (name opcode n-operands pushp) - (declare (type (mod 4) n-operands)) - (let ((function (svref **fop-funs** opcode))) - (when (functionp function) - (let ((oname (nth-value 2 (function-lambda-expression function)))) - (when (and oname (not (eq oname name))) - (error "fop ~S with opcode ~D conflicts with fop ~S." - name opcode oname)))) - (let ((existing-opcode (get name 'opcode))) - (when (and existing-opcode (/= existing-opcode opcode)) - (error "multiple codes for fop name ~S: ~D and ~D" - name opcode existing-opcode))) - (setf (get name 'opcode) opcode - (svref **fop-funs** opcode) (symbol-function name) - (aref (car **fop-signatures**) opcode) n-operands - (sbit (cdr **fop-signatures**) opcode) pushp)) - name) - ;;; Compatibity macros that allow some fops to share the identical ;;; body between genesis and the target code. #-sb-xc-host @@ -100,7 +24,7 @@ (with-fast-read-byte ((unsigned-byte 8) stream) (dotimes (i length) (setf (aref string i) - (sb-xc:code-char (fast-read-byte))))) + (code-char (fast-read-byte))))) string) ;;; Variation 2: base-string, transfer elements of type (unsigned-byte 8) (defun read-base-string-as-bytes (stream string &optional (length (length string))) @@ -110,7 +34,7 @@ (with-fast-read-byte ((unsigned-byte 8) stream) (dotimes (i length) (setf (aref string i) - (sb-xc:code-char (fast-read-byte))))) + (code-char (fast-read-byte))))) string) ;;; Variation 3: character-string, transfer elements of type varint (defun read-char-string-as-varints @@ -133,7 +57,7 @@ unless (logbitp 7 octet) return accum))) (dotimes (i length) (setf (aref string i) - (sb-xc:code-char (read-varint)))))) + (code-char (read-varint)))))) string) ;;;; miscellaneous fops @@ -159,18 +83,18 @@ (let ((res (%make-instance size)) ; number of words excluding header ;; Discount the layout from number of user-visible words. (n-data-words (- size sb-vm:instance-data-start))) - (setf (%instance-layout res) layout) + (setf (%instance-wrapper res) layout) (with-fop-stack ((stack (operand-stack)) ptr n-data-words) (declare (type index ptr)) - (let ((bitmap (layout-bitmap layout))) + (let ((bitmap (wrapper-bitmap layout))) ;; Values on the stack are in the same order as in the structure itself. (do ((i sb-vm:instance-data-start (1+ i))) ((>= i size)) (declare (type index i)) (let ((val (fop-stack-ref ptr))) (if (logbitp i bitmap) - (setf (%instance-ref res i) val) - (setf (%raw-instance-ref/word res i) val)) + (%instance-set res i val) + (%raw-instance-set/word res i val)) (incf ptr))))) res)) @@ -436,45 +360,19 @@ (set-array-header res vec length nil 0 (fop-list (fasl-input) rank) nil t) res)) -(defglobal **saetp-bits-per-length** - (let ((array (make-array (1+ sb-vm:widetag-mask) - :element-type '(unsigned-byte 8) - :initial-element 255))) - (loop for saetp across sb-vm:*specialized-array-element-type-properties* - do - (setf (aref array (sb-vm:saetp-typecode saetp)) - (sb-vm:saetp-n-bits saetp))) - array) - "255 means bad entry.") -(declaim (type (simple-array (unsigned-byte 8) (#.(1+ sb-vm:widetag-mask))) - **saetp-bits-per-length**)) - (define-fop 43 (fop-spec-vector ((:operands length))) (let* ((widetag (read-byte-arg (fasl-input-stream))) - (bits-per-length (aref **saetp-bits-per-length** widetag)) - (bits (progn (aver (< bits-per-length 255)) - (* length bits-per-length))) + (bits (* length (sb-vm::simple-array-widetag->bits-per-elt widetag))) (bytes (ceiling bits sb-vm:n-byte-bits)) (words (ceiling bytes sb-vm:n-word-bytes)) - (vector - (progn (aver (/= widetag sb-vm:simple-vector-widetag)) - (logically-readonlyize - (allocate-vector widetag length words))))) + (vector (logically-readonlyize + (allocate-vector #+(and (not sb-xc-host) ubsan) nil + widetag length words)))) (declare (type index length bytes words) (type word bits)) (read-n-bytes (fasl-input-stream) vector 0 bytes) vector)) -(define-fop 53 (fop-eval (expr)) ; This seems to be unused - (if (skip-until) - expr - (eval expr))) - -(define-fop 54 (fop-eval-for-effect (expr) nil) ; This seems to be unused - (unless (skip-until) - (eval expr)) - nil) - (defun fop-funcall* (argc stack skipping) (with-fop-stack ((stack) ptr (1+ argc)) (unless skipping @@ -508,7 +406,8 @@ (setf (svref (ref-fop-table (fasl-input) tbl-slot) idx) val)) (define-fop 14 :not-host (fop-structset ((:operands tbl-slot idx) val) nil) - (setf (%instance-ref (ref-fop-table (fasl-input) tbl-slot) idx) val)) + (%instance-set (ref-fop-table (fasl-input) tbl-slot) idx val) + val) ; I can't remmeber whether this fop needs to return VAL. maybe? (define-fop 15 (fop-nthcdr ((:operands n) obj)) (nthcdr n obj)) @@ -522,44 +421,68 @@ ;;; putting the implementation and version in required fields in the ;;; fasl file header.) +(define-load-time-global *show-new-code* nil) (define-fop 16 :not-host (fop-load-code ((:operands header n-code-bytes n-fixups))) - (let* ((n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) + (let* ((n-simple-funs (read-unsigned-byte-32-arg (fasl-input-stream))) + (n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) (n-boxed-words (ash header -1)) (n-constants (- n-boxed-words sb-vm:code-constants-offset))) ;; stack has (at least) N-CONSTANTS words plus debug-info (with-fop-stack ((stack (operand-stack)) ptr (1+ n-constants)) - (let* ((debug-info-index (+ ptr n-constants)) - (n-boxed-words (+ sb-vm:code-constants-offset n-constants)) - (code (sb-c:allocate-code-object - (if (oddp header) :immobile :dynamic) - n-named-calls - (align-up n-boxed-words sb-c::code-boxed-words-align) - n-code-bytes))) + ;; We've already ensured that all FDEFNs the code uses exist. + ;; This happened by virtue of calling fop-fdefn for each. + (let ((stack-index (+ ptr (* n-simple-funs sb-vm:code-slots-per-simple-fun)))) + (dotimes (i n-named-calls) + (aver (typep (svref stack stack-index) 'fdefn)) + (incf stack-index))) + (let ((code (sb-c:allocate-code-object + (if (oddp header) :immobile :dynamic) + n-named-calls + (align-up n-boxed-words sb-c::code-boxed-words-align) + n-code-bytes))) (with-pinned-objects (code) ;; * DO * NOT * SEPARATE * THESE * STEPS * ;; For a full explanation, refer to the comment above MAKE-CORE-COMPONENT ;; concerning the corresponding use therein of WITH-PINNED-OBJECTS etc. + #-darwin-jit (read-n-bytes (fasl-input-stream) (code-instructions code) 0 n-code-bytes) + #+darwin-jit + (let ((buf (make-array n-code-bytes :element-type '(unsigned-byte 8)))) + (read-n-bytes (fasl-input-stream) buf 0 n-code-bytes) + (with-pinned-objects (buf) + (sb-vm::jit-memcpy (code-instructions code) (vector-sap buf) n-code-bytes))) + (aver (= (code-n-entries code) n-simple-funs)) ;; Serial# shares a word with the jump-table word count, ;; so we can't assign serial# until after all raw bytes are copied in. (sb-c::assign-code-serialno code) (sb-thread:barrier (:write)) ;; Assign debug-info last. A code object that has no debug-info will never ;; have its fun table accessed in conservative_root_p() or pin_object(). - (setf (%code-debug-info code) (svref stack debug-info-index)) + (setf (%code-debug-info code) (svref stack (+ ptr n-constants))) ;; Boxed constants can be assigned only after figuring out where the range ;; of implicitly tagged words is, which requires knowing how many functions ;; are in the code component, which requires reading the code trailer. - (let* ((fdefns-start (sb-impl::code-fdefns-start-index code)) - (fdefns-end (1- (+ fdefns-start n-named-calls)))) ; inclusive bound - (loop for i of-type index from sb-vm:code-constants-offset - for j of-type index from ptr below debug-info-index - do (let ((constant (svref stack j))) - (if (<= fdefns-start i fdefns-end) - (sb-c::set-code-fdefn code i constant) - (setf (code-header-ref code i) constant))))) + (let* ((header-index sb-vm:code-constants-offset) + (stack-index ptr)) + (declare (type index header-index stack-index)) + (dotimes (n n-simple-funs) + (dotimes (i sb-vm:code-slots-per-simple-fun) + (setf (code-header-ref code header-index) (svref stack stack-index)) + (incf header-index) + (incf stack-index))) + (dotimes (i n-named-calls) + (sb-c::set-code-fdefn code header-index (svref stack stack-index)) + (incf header-index) + (incf stack-index)) + (do () ((>= header-index n-boxed-words)) + (setf (code-header-ref code header-index) (svref stack stack-index)) + (incf header-index) + (incf stack-index))) ;; Now apply fixups. The fixups to perform are popped from the fasl stack. (sb-c::apply-fasl-fixups stack code n-fixups)) + (when *show-new-code* + (let ((*print-pretty* nil)) + (format t "~&New code(~Db,load): ~A~%" (code-object-size code) code))) #-sb-xc-host (when (typep (code-header-ref code (1- n-boxed-words)) '(cons (eql sb-c::coverage-map))) @@ -578,25 +501,13 @@ (define-fop 18 :not-host (fop-known-fun (name)) (%coerce-name-to-fun name)) -;; This FOP is only encountered in cross-compiled files for cold-load. +;; This FOP is only encountered in cross-compiled FASLs for cold load, +;; and is a no-op except in cold load. A developer may want to load a +;; cross-compiled FASL into a running system, and this FOP doesn't +;; have to do anything, as the system can load top level forms and +;; will define the function normally. (define-fop 74 :not-host (fop-fset (name fn) nil) - ;; Ordinary, not-for-cold-load code shouldn't need to mess with this - ;; at all, since it's only used as part of the conspiracy between - ;; the cross-compiler and GENESIS to statically link FDEFINITIONs - ;; for cold init. - (warn "~@") - ;; Unlike CMU CL, we don't treat this as a no-op in ordinary code. - ;; If the user (or, more likely, developer) is trying to reload - ;; compiled-for-cold-load code into a warm SBCL, we'll do a warm - ;; assignment. (This is partly for abstract tidiness, since the warm - ;; assignment is the closest analogy to what happens at cold load, - ;; and partly because otherwise our compiled-for-cold-load code will - ;; fail, since in SBCL things like compiled-for-cold-load %DEFUN - ;; depend more strongly than in CMU CL on FOP-FSET actually doing - ;; something.) - (setf (fdefinition name) fn)) + (declare (ignore name fn))) ;;; Modify a slot of the code boxed constants. (define-fop 19 (fop-alter-code ((:operands index) code value) nil) @@ -606,7 +517,7 @@ (setf (code-header-ref code index) value) (values))) -(define-fop 20 :not-host (fop-fun-entry ((:operands fun-index) code-object)) +(define-fop 20 (fop-fun-entry ((:operands fun-index) code-object)) (%code-entry-point code-object fun-index)) ;;;; assemblerish fops diff -Nru sbcl-2.1.1/src/code/format-directive.lisp sbcl-2.1.11/src/code/format-directive.lisp --- sbcl-2.1.1/src/code/format-directive.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/format-directive.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -8,7 +8,46 @@ ;;;; files for more information. (in-package "SB-FORMAT") - + +(defstruct (format-directive (:copier nil) + (:constructor %make-directive + (string start end params bits function)) + (:conc-name directive-)) + (string (missing-arg) :type simple-string :read-only t) + (start (missing-arg) :type (and unsigned-byte fixnum) :read-only t) + (end (missing-arg) :type (and unsigned-byte fixnum) :read-only t) + (bits nil :type (unsigned-byte 9) :read-only t) ; colon, atsign, char + ;; for early binding to the function in "~/pkg:fun/" directives + (function nil :type symbol :read-only t) + (params nil :type list :read-only t)) +(declaim (freeze-type format-directive)) + +(defun make-format-directive (string start end params colon atsign char symbol) + (let ((code (char-code char))) + (%make-directive string start end params + (logior (if colon #x100 0) + (if atsign #x080 0) + (if (< code 128) code 0)) + symbol))) + +(defglobal *format-directive-expanders* (make-array 128 :initial-element nil)) +(declaim (type (simple-vector 128) + *format-directive-expanders*)) + +(defun %print-format-error (condition stream) + (format stream + "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]" + (format-error-print-banner condition) + 'format + (format-error-complaint condition) + (format-error-args condition) + (format-error-control-string condition) + (format-error-offset condition) + (format-error-second-relative condition))) + +(defvar *default-format-error-control-string* nil) +(defvar *default-format-error-offset* nil) + (define-condition format-error (error reference-condition) ((complaint :reader format-error-complaint :initarg :complaint) (args :reader format-error-args :initarg :args :initform nil) @@ -24,17 +63,6 @@ (:report %print-format-error) (:default-initargs :references nil)) -(defun %print-format-error (condition stream) - (format stream - "~:[~*~;error in ~S: ~]~?~@[~% ~A~% ~V@T^~@[~V@T^~]~]" - (format-error-print-banner condition) - 'format - (format-error-complaint condition) - (format-error-args condition) - (format-error-control-string condition) - (format-error-offset condition) - (format-error-second-relative condition))) - (defun format-error* (complaint args &rest initargs &key &allow-other-keys) (apply #'error 'format-error :complaint complaint :args args initargs)) @@ -53,33 +81,13 @@ (format-error-at* control-string offset complaint args)) -(defstruct (format-directive (:copier nil) - (:constructor %make-directive - (string start end params bits function)) - (:conc-name directive-)) - (string (missing-arg) :type simple-string :read-only t) - (start (missing-arg) :type (and unsigned-byte fixnum) :read-only t) - (end (missing-arg) :type (and unsigned-byte fixnum) :read-only t) - (bits nil :type (unsigned-byte 9) :read-only t) ; colon, atsign, char - ;; for early binding to the function in "~/pkg:fun/" directives - (function nil :type symbol :read-only t) - (params nil :type list :read-only t)) -(declaim (freeze-type format-directive)) - -(defun make-format-directive (string start end params colon atsign char symbol) - (let ((code (sb-xc:char-code char))) - (%make-directive string start end params - (logior (if colon #x100 0) - (if atsign #x080 0) - (if (< code 128) code 0)) - symbol))) (declaim (inline directive-colonp directive-atsignp)) (defun directive-colonp (x) (logbitp 8 (directive-bits x))) (defun directive-atsignp (x) (logbitp 7 (directive-bits x))) (declaim (inline directive-code directive-character)) (defun directive-code (x) (logand (directive-bits x) #x7F)) -(defun directive-character (x) (sb-xc:code-char (directive-code x))) +(defun directive-character (x) (code-char (directive-code x))) ;;; This works even if directive char is invalid, where -CHARACTER ;;; would return (code-char 0) (defun directive-char-name (x) @@ -87,7 +95,7 @@ (char-name (if (eql byte 0) ;; extract the character from the string (char (directive-string x) (1- (directive-end x))) - (sb-xc:code-char byte))))) + (code-char byte))))) (defun check-modifier (modifier-name value) (when value diff -Nru sbcl-2.1.1/src/code/format.lisp sbcl-2.1.11/src/code/format.lisp --- sbcl-2.1.1/src/code/format.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/code/format.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,1618 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-FORMAT") + +;;;; TOKENIZE-CONTROL-STRING + +;;; The case for caching is to speed up out-of-line calls that use a fixed +;;; control string in a loop, not to avoid re-tokenizing all strings that +;;; happen to be STRING= to that string. +;;; (Might we want to bypass the cache when compile-time tokenizing?) +#+sb-xc-host +(defun tokenize-control-string (string) + (combine-directives + (%tokenize-control-string string 0 (length string) nil) + t)) +#-sb-xc-host +(defun-cached (tokenize-control-string + :memoizer memoize + :hash-bits 7 + :hash-function #'pointer-hash) + ((string eq)) + (declare (simple-string string)) + (macrolet ((compute-it () + `(combine-directives + (%tokenize-control-string string 0 (length string) nil) + t))) + (if (logtest (get-header-data string) + ;; shareable = readonly + (ash (logior sb-vm:+vector-shareable+ + sb-vm:+vector-shareable-nonstd+) + sb-vm:array-flags-data-position)) + (memoize (compute-it)) + (compute-it)))) + +;;; If at some point I can figure out how to *CORRECTLY* utilize +;;; non-simple strings, then the INDEX and END will bound the parse. +;;; [Tokenization is the easy part, it's the substring extraction +;;; and processing, and error reporting, that become very complicated] +(defun %tokenize-control-string (string index end symbols) + (declare (simple-string string)) + (let ((result nil) + ;; FIXME: consider rewriting this 22.3.5.2-related processing + ;; using specials to maintain state and doing the logic inside + ;; the directive expanders themselves. + (block) + (pprint) + (semicolon) + (justification-semicolon)) + (loop + (let ((next-directive (or (position #\~ string :start index :end end) end))) + (when (> next-directive index) + (push (possibly-base-stringize (subseq string index next-directive)) + result)) + (when (= next-directive end) + (return)) + (let* ((directive (parse-directive string next-directive symbols)) + (char (directive-character directive))) + ;; this processing is required by CLHS 22.3.5.2 + (cond + ((char= char #\<) (push directive block)) + ((and block (char= char #\;) (directive-colonp directive)) + (setf semicolon directive)) + ((char= char #\>) + (unless block + (format-error-at string next-directive + "~~> without a matching ~~<")) + (cond + ((directive-colonp directive) + (unless pprint + (setf pprint (car block))) + (setf semicolon nil)) + (semicolon + (unless justification-semicolon + (setf justification-semicolon semicolon)))) + (pop block)) + ;; block cases are handled by the #\< expander/interpreter + ((not block) + (case char + ((#\W #\I #\_) (unless pprint (setf pprint directive))) + (#\T (when (and (directive-colonp directive) + (not pprint)) + (setf pprint directive)))))) + (push directive result) + (when (char= (directive-character directive) #\/) + (pop symbols)) + (setf index (directive-end directive))))) + (when (and pprint justification-semicolon) + (let ((pprint-offset (1- (directive-end pprint))) + (justification-offset + (1- (directive-end justification-semicolon)))) + (format-error-at* + string (min pprint-offset justification-offset) + "Misuse of justification and pprint directives" '() + :second-relative (- (max pprint-offset justification-offset) + (min pprint-offset justification-offset) + 1) + :references '((:ansi-cl :section (22 3 5 2)))))) + (nreverse result))) + +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) +(defun parse-directive (string start symbols) + (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) + (end (length string))) + (flet ((get-char () + (if (= posn end) + (format-error-at string start + "String ended before directive was found") + (schar string posn))) + (check-ordering () + (when (or colonp atsignp) + (format-error-at* + string posn + "Parameters found after #\\: or #\\@ modifier" '() + :references '((:ansi-cl :section (22 3))))))) + (loop + (let ((char (get-char))) + (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) + (check-ordering) + (multiple-value-bind (param new-posn) + (parse-integer string :start posn :junk-allowed t) + (push (cons posn param) params) + (setf posn new-posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return))))) + ((or (char= char #\v) + (char= char #\V)) + (check-ordering) + (push (cons posn :arg) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\#) + (check-ordering) + (push (cons posn :remaining) params) + (incf posn) + (case (get-char) + (#\,) + ((#\: #\@) + (decf posn)) + (t + (return)))) + ((char= char #\') + (check-ordering) + (incf posn) + (push (cons posn (get-char)) params) + (incf posn) + (unless (char= (get-char) #\,) + (decf posn))) + ((char= char #\,) + (check-ordering) + (push (cons posn nil) params)) + ((char= char #\:) + (if colonp + (format-error-at* + string posn "Too many colons supplied" '() + :references '((:ansi-cl :section (22 3)))) + (setf colonp t))) + ((char= char #\@) + (if atsignp + (format-error-at* + string posn "Too many #\\@ characters supplied" '() + :references '((:ansi-cl :section (22 3)))) + (setf atsignp t))) + (t + (when (and (char= (schar string (1- posn)) #\,) + (or (< posn 2) + (char/= (schar string (- posn 2)) #\'))) + (check-ordering) + (push (cons (1- posn) nil) params)) + (return)))) + (incf posn)) + (let ((char (get-char))) + (when (char= char #\/) + (let ((closing-slash (position #\/ string :start (1+ posn)))) + (if closing-slash + (setf posn closing-slash) + (format-error-at string posn "No matching closing slash")))) + (make-format-directive + string start (1+ posn) + (nreverse params) colonp atsignp (char-upcase char) + (when (eql char #\/) (car symbols)))))))) + +;;;; specials used to communicate information + +;;; Used both by the expansion stuff and the interpreter stuff. When it is +;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. +(defvar *up-up-and-out-allowed* nil) + +;;; Used by the interpreter stuff. When it's non-NIL, it's a function +;;; that will invoke PPRINT-POP in the right lexical environemnt. +(defvar *logical-block-popper* nil) +(declaim (type (or null function) *logical-block-popper*) + (always-bound *logical-block-popper*)) + +;;; Used by the expander stuff. This is bindable so that ~<...~:> +;;; can change it. +(defvar *expander-next-arg-macro* 'expander-next-arg) + +;;; Used by the expander stuff. Initially starts as T, and gets set to NIL +;;; if someone needs to do something strange with the arg list (like use +;;; the rest, or something). +(defvar *only-simple-args*) + +;;; Used by the expander stuff. We do an initial pass with this as NIL. +;;; If someone doesn't like this, they (THROW 'NEED-ORIG-ARGS NIL) and we try +;;; again with it bound to T. If this is T, we don't try to do anything +;;; fancy with args. +(defvar *orig-args-available* nil) + +;;; Used by the expander stuff. List of (symbol . offset) for simple args. +(defvar *simple-args*) + +;;; Make a few simplifications to the directive list in INPUT, +;;; including translation of ~% to literal newline. +;;; I think that this does not have implications on conditional newlines +;;; vis a vis "When a line break is inserted by any type of conditional +;;; newline, any blanks that immediately precede the conditional newline +;;; are omitted". i.e. one could argue that nonliteral blanks are not +;;; quite the same as literal blanks, i.e. not subject to removal, +;;; but I don't think that's true, and in fact that is the source of +;;; an extremely subtle bug that writing the #\space character as a +;;; physical space character followed by a conditional newline is, +;;; if taken literally, supposed to remove the desired output. +(defun combine-directives (input literalize-tilde) + (let (output) + (labels ((emit-string (string) + (if (stringp (car output)) + (rplaca output (concat (car output) string)) + (push string output))) + (emit-placeholder-p () + ;; Return T if an otherwise empty string inside ~{ ... ~} must be + ;; kept in order to avoid turning "~{~0|~}" (etc) into "~{~}". + ;; The latter control string means something completely different. + (and (format-directive-p (car output)) + (eql #\{ (directive-character (car output))))) + (emit-directive (directive) + ;; If the head of output is the empty string and DIRECTIVE is + ;; NOT a closing curly brace, we can reuse the first cons cell. + (if (and (typep (car output) '(string 0)) + (char/= (directive-character directive) #\})) + (rplaca output directive) + (push directive output))) + (concat (first second) + ;; The result is a base-string iff both inputs are base-string. + ;; %TOKENIZE-CONTROL-STRING calls POSSIBLY-BASE-STRINGIZE + ;; on all pieces of the input. + ;; I suspect that this may be permissible for CONCATENATE generally + ;; when given 'STRING as its output type with base-string as inputs. + ;; But as with all things string, the spec is unclear as usual imho. + (cond ((and (typep first 'base-string) + (typep second 'base-string)) + (concatenate 'base-string first second)) + (t + (concatenate 'string first second))))) + (loop + (unless input (return (nreverse output))) + (let ((item (pop input))) + (etypecase item + (string + (aver (plusp (length item))) + (emit-string item)) + ;; - Handle tilde-newline immediately + ;; - Turn "~%" into literal newline (for parameter N <=127) + ;; - Unless x-compiling, turn "~|" into literal form-feed (ditto) + ;; - Optionally turn "~~" into literal tilde (ditto) + (format-directive + (let ((params (directive-params item)) + (colon (directive-colonp item)) + (atsign (directive-atsignp item)) + (char (directive-character item))) + (block nil + (case char + (#\Newline + ;; tilde newline wants no params, and not both colon+atsign + (when (and (not params) (not (and colon atsign))) + ;; atsign = preserve newline / colon = preserve whitespace + (let ((s (concat (if atsign + #.(make-string 1 :initial-element #\Newline) + "") + (if (and (not colon) (stringp (car input))) + (string-left-trim + ;; #\Tab is a nonstandard char + `(#-sb-xc-host ,(code-char tab-char-code) + #\space #\newline) + (pop input)) + "")))) + (when (or (plusp (length s)) (emit-placeholder-p)) + (emit-string s))) + (return))) + ;; TODO: #\& with a literal parameter of 0 is equivalent + ;; to the empty string. + ((#\% #\~ #-sb-xc-host #\|) ; #\Page is a nonstandard char + (let ((n (or (cdar params) 1))) + (when (and (not (or colon atsign)) + (or (null params) (singleton-p params)) + (typep n '(mod 128)) + ;; Don't insert literal tilde when parsing/ + ;; unparsing to create a FMT-CONTROL instance. + (or (not (eql char #\~)) literalize-tilde)) + (when (or (plusp n) (emit-placeholder-p)) + (let ((char (case char + (#\% #\Newline) + #-sb-xc-host (#\| (code-char form-feed-char-code)) + (t char)))) + (emit-string (make-string n :initial-element char)))) + (return))))) + (emit-directive item)))))))))) + +;;;; FORMATTER stuff + +(sb-xc:defmacro formatter (control-string) + `#',(%formatter control-string)) + +(defun %formatter (control-string &optional (arg-count 0) (need-retval t) + &aux (lambda-name + (possibly-base-stringize + (concatenate 'string "fmt$" control-string)))) + ;; ARG-COUNT is supplied only when the use of this formatter is in a literal + ;; call to FORMAT, in which case we can possibly elide &optional parsing. + ;; But we can't in general, because FORMATTER may be called by users + ;; to obtain functions that may be invoked in random wrong ways. + ;; NEED-RETVAL signifies that the caller wants back the list of + ;; unconsumed arguments. This is the default assumption. + (block nil + (catch 'need-orig-args + (let* ((*simple-args* nil) + (*only-simple-args* t) + (control-string (coerce control-string 'simple-string)) + (guts (expand-control-string control-string)) ; can throw + (required nil) + (optional nil)) + (dolist (arg *simple-args*) + (cond ((plusp arg-count) + (push (car arg) required) + (decf arg-count)) + (t + (push `(,(car arg) + (args-exhausted ,control-string ,(cdr arg))) + optional)))) + (return `(named-lambda ,lambda-name + (stream ,@required + ,@(if optional '(&optional)) ,@optional + &rest args) + (declare (ignorable stream args)) + ,guts + ,(and need-retval 'args))))) + (let ((*orig-args-available* t) + (*only-simple-args* nil)) + `(named-lambda ,lambda-name (stream &rest orig-args) + (declare (ignorable stream) (muffle-conditions compiler-note)) + (let ((args orig-args)) + ,(expand-control-string control-string) + ,(and need-retval 'args)))))) + +(defun args-exhausted (control-string offset) + (format-error-at control-string offset "No more arguments")) + +(defvar *format-gensym-counter*) +(defun expand-control-string (string) + (let* ((string (etypecase string + (simple-string + string) + (string + (coerce string 'simple-string)))) + (*default-format-error-control-string* string) + (*format-gensym-counter* 0) + (directives (tokenize-control-string string))) + `(block nil + ,@(expand-directive-list directives)))) + +(defun expand-directive-list (directives) + (let ((results nil) + previous + (remaining-directives directives)) + (loop + (unless remaining-directives + (return)) + (multiple-value-bind (form new-directives) + (expand-directive (car remaining-directives) + (cdr remaining-directives)) + (flet ((merge-string (string) + (cond (previous + ;; It would be nice if (CONCATENTE 'STRING) + ;; could return the "smallest" string type + ;; able to hold the result. Or at least if we + ;; had a better interface than wrapping + ;; it with POSSIBLY-BASE-STRINGIZE since that + ;; conses two new strings usually. + (let ((concat + (possibly-base-stringize + (concatenate 'string + (string previous) + (string string))))) + (setf previous concat) + (setf (car results) + `(write-string ,concat stream)))) + (t + (setf previous string) + (push form results))))) + (cond ((not form)) + ((typep form '(cons (member write-string write-char) + (cons (or string character)))) + (merge-string (second form))) + ((typep form '(cons (eql terpri))) + (merge-string #\Newline)) + (t + (push form results) + (setf previous nil)))) + (setf remaining-directives new-directives))) + (nreverse results))) + +(defun expand-directive (directive more-directives) + (etypecase directive + (format-directive + (let ((expander + (aref *format-directive-expanders* (directive-code directive))) + (*default-format-error-offset* + (1- (directive-end directive)))) + (if (functionp expander) + (funcall expander directive more-directives) + (format-error "Unknown directive ~@[(character: ~A)~]" + (directive-char-name directive))))) + ((simple-string 1) + (values `(write-char ,(schar directive 0) stream) + more-directives)) + (simple-string + (values `(write-string ,directive stream) + more-directives)))) + +(sb-xc:defmacro expander-next-arg (string offset) + `(if args + (pop args) + (format-error-at ,string ,offset "No more arguments"))) + +(defun expand-next-arg (&optional offset) + (if (or *orig-args-available* (not *only-simple-args*)) + `(,*expander-next-arg-macro* + ,*default-format-error-control-string* + ,(or offset *default-format-error-offset*)) + (let ((symbol + (without-package-locks + (package-symbolicate + #.(find-package "SB-FORMAT") + "FORMAT-ARG" + (write-to-string (incf *format-gensym-counter*) + :pretty nil :base 10 :radix nil))))) + (push (cons symbol (or offset *default-format-error-offset*)) + *simple-args*) + symbol))) + +(defmacro expand-bind-defaults (specs params &body body) + (once-only ((params params)) + (if specs + (collect ((expander-bindings) (runtime-bindings)) + (dolist (spec specs) + (destructuring-bind (var default) spec + (let ((symbol (sb-xc:gensym "FVAR"))) + (expander-bindings + `(,var ',symbol)) + (runtime-bindings + `(list ',symbol + (let* ((param-and-offset (pop ,params)) + (offset (car param-and-offset)) + (param (cdr param-and-offset))) + (case param + (:arg `(or ,(expand-next-arg offset) ,,default)) + (:remaining + (setf *only-simple-args* nil) + '(length args)) + ((nil) ,default) + (t param)))))))) + `(let ,(expander-bindings) + `(let ,(list ,@(runtime-bindings)) + ,@(if ,params + (format-error-at + nil (caar ,params) + "Too many parameters, expected no more than ~W" + ,(length specs))) + ,,@body))) + `(progn + (when ,params + (format-error-at nil (caar ,params) + "Too many parameters, expected none")) + ,@body)))) + +;;;; format directive machinery + +(defmacro def-complex-format-directive (char lambda-list &body body) + (let ((defun-name (intern (format nil + "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" + char))) + (directive (sb-xc:gensym "DIRECTIVE")) + (directives (if lambda-list (car (last lambda-list)) (sb-xc:gensym "DIRECTIVES")))) + `(progn + (defun ,defun-name (,directive ,directives) + ,@(if lambda-list + `((let ,(mapcar (lambda (var) + `(,var + (,(symbolicate "DIRECTIVE-" var) ,directive))) + (butlast lambda-list)) + ,@body)) + `((declare (ignore ,directive ,directives)) + ,@body))) + (%set-format-directive-expander ,char #',defun-name)))) + +(defmacro def-format-directive (char lambda-list &body body) + (let ((directives (sb-xc:gensym "DIRECTIVES")) + (declarations nil) + (body-without-decls body)) + (loop + (let ((form (car body-without-decls))) + (unless (and (consp form) (eq (car form) 'declare)) + (return)) + (push (pop body-without-decls) declarations))) + (setf declarations (reverse declarations)) + `(def-complex-format-directive ,char (,@lambda-list ,directives) + ,@declarations + (values (progn ,@body-without-decls) + ,directives)))) + +(defun %set-format-directive-expander (char fn) + (let ((code (char-code (char-upcase char)))) + (setf (aref *format-directive-expanders* code) fn)) + char) + +(defun find-directive (directives kind stop-at-semi) + (if directives + (let ((next (car directives))) + (if (format-directive-p next) + (let ((char (directive-character next))) + (if (or (char= kind char) + (and stop-at-semi (char= char #\;))) + (car directives) + (find-directive + (cdr (flet ((after (char) + (member (find-directive (cdr directives) + char + nil) + directives))) + (case char + (#\( (after #\))) + (#\< (after #\>)) + (#\[ (after #\])) + (#\{ (after #\})) + (t directives)))) + kind stop-at-semi))) + (find-directive (cdr directives) kind stop-at-semi))))) + +;;;; format directives for simple output + +(def-format-directive #\A (colonp atsignp params) + (if params + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp + ,mincol ,colinc ,minpad ,padchar)) + `(princ ,(if colonp + `(or ,(expand-next-arg) "()") + (expand-next-arg)) + stream))) + +(def-format-directive #\S (colonp atsignp params) + (cond (params + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) + params + `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))) + (colonp + `(let ((arg ,(expand-next-arg))) + (if arg + (prin1 arg stream) + (princ "()" stream)))) + (t + `(prin1 ,(expand-next-arg) stream)))) + +(def-format-directive #\C (colonp atsignp params string end) + (expand-bind-defaults () params + (let ((n-arg (sb-xc:gensym "ARG"))) + `(let ((,n-arg ,(expand-next-arg))) + (unless (typep ,n-arg 'character) + (format-error-at ,string ,(1- end) + "~S is not of type CHARACTER." ,n-arg)) + ,(cond (colonp + `(format-print-named-character ,n-arg stream)) + (atsignp + `(prin1 ,n-arg stream)) + (t + `(write-char ,n-arg stream))))))) + +(def-format-directive #\W (colonp atsignp params) + (expand-bind-defaults () params + (if (or colonp atsignp) + `(let (,@(when colonp + '((*print-pretty* t))) + ,@(when atsignp + '((*print-level* nil) + (*print-length* nil)))) + (output-object ,(expand-next-arg) stream)) + `(output-object ,(expand-next-arg) stream)))) + +;;;; format directives for integer output + +(defun expand-format-integer (base colonp atsignp params) + (if (or colonp atsignp params) + (expand-bind-defaults + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + params + `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp + ,base ,mincol ,padchar ,commachar + ,commainterval)) + `(let ((*print-base* ,base) + (*print-radix* nil)) + (princ ,(expand-next-arg) stream)))) + +(def-format-directive #\D (colonp atsignp params) + (expand-format-integer 10 colonp atsignp params)) + +(def-format-directive #\B (colonp atsignp params) + (expand-format-integer 2 colonp atsignp params)) + +(def-format-directive #\O (colonp atsignp params) + (expand-format-integer 8 colonp atsignp params)) + +(def-format-directive #\X (colonp atsignp params) + (expand-format-integer 16 colonp atsignp params)) + +(def-format-directive #\R (colonp atsignp params string end) + (expand-bind-defaults + ((base nil) (mincol 0) (padchar #\space) (commachar #\,) + (commainterval 3)) + params + (let ((n-arg (sb-xc:gensym "ARG"))) + `(let ((,n-arg ,(expand-next-arg))) + (unless (or ,base + (integerp ,n-arg)) + (format-error-at ,string ,(1- end) "~S is not of type INTEGER." ,n-arg)) + (if ,base + (format-print-integer stream ,n-arg ,colonp ,atsignp + ,base ,mincol + ,padchar ,commachar ,commainterval) + ,(if atsignp + (if colonp + `(format-print-old-roman stream ,n-arg) + `(format-print-roman stream ,n-arg)) + (if colonp + `(format-print-ordinal stream ,n-arg) + `(format-print-cardinal stream ,n-arg)))))))) + +;;;; format directive for pluralization + +(def-format-directive #\P (colonp atsignp params end) + (expand-bind-defaults () params + (let ((arg (cond + ((not colonp) + (expand-next-arg)) + (*orig-args-available* + `(if (eq orig-args args) + (format-error-at + ,*default-format-error-control-string* ,(1- end) + "No previous argument") + (do ((arg-ptr orig-args (cdr arg-ptr))) + ((eq (cdr arg-ptr) args) + (car arg-ptr))))) + (*only-simple-args* + (unless *simple-args* + (format-error "No previous argument")) + (caar *simple-args*)) + (t + (/show0 "THROWing NEED-ORIG-ARGS from tilde-P") + (throw 'need-orig-args nil))))) + (if atsignp + `(write-string (if (eql ,arg 1) "y" "ies") stream) + `(unless (eql ,arg 1) (write-char #\s stream)))))) + +;;;; format directives for floating point output + +(def-format-directive #\F (colonp atsignp params) + (check-modifier "colon" colonp) + (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params + `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) + +(def-format-directive #\E (colonp atsignp params) + (check-modifier "colon" colonp) + (expand-bind-defaults + ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) + params + `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark + ,atsignp))) + +(def-format-directive #\G (colonp atsignp params) + (check-modifier "colon" colonp) + (expand-bind-defaults + ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) + params + `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) + +(def-format-directive #\$ (colonp atsignp params) + (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params + `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp + ,atsignp))) + +;;;; format directives for line/page breaks etc. + +(def-format-directive #\% (colonp atsignp params) + (check-modifier "colon" colonp) + (check-modifier "at-sign" atsignp) + (cond ((not params) + '(terpri stream)) + ((typep params '(cons (cons * (mod 65536)) null)) + `(write-string ,(make-string (cdar params) :initial-element #\Newline) stream)) + (t + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (terpri stream)))))) + +(def-format-directive #\& (colonp atsignp params) + (check-modifier "colon" colonp) + (check-modifier "at-sign" atsignp) + (if params + (expand-bind-defaults ((count 1)) params + `(progn + (when (plusp ,count) + (fresh-line stream) + (dotimes (i (1- ,count)) + (terpri stream))))) + '(fresh-line stream))) + +(def-format-directive #\| (colonp atsignp params) + (check-modifier "colon" colonp) + (check-modifier "at-sign" atsignp) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char (code-char form-feed-char-code) stream))) + '(write-char (code-char form-feed-char-code) stream))) + +(def-format-directive #\~ (colonp atsignp params) + (check-modifier "colon" colonp) + (check-modifier "at-sign" atsignp) + (if params + (expand-bind-defaults ((count 1)) params + `(dotimes (i ,count) + (write-char #\~ stream))) + '(write-char #\~ stream))) + +;;; We'll only get here when the directive usage is illegal. +;;; COMBINE-DIRECTIVES would have handled a legal directive. +(def-complex-format-directive #\newline (colonp atsignp params directives) + (check-modifier '("colon" "at-sign") (and colonp atsignp)) + (values (expand-bind-defaults () params) + (bug "Unreachable ~S" directives))) + +;;;; format directives for tabs and simple pretty printing + +(def-format-directive #\T (colonp atsignp params) + (if colonp + (expand-bind-defaults ((n 1) (m 1)) params + `(pprint-tab ,(if atsignp :section-relative :section) + ,n ,m stream)) + (if atsignp + (expand-bind-defaults ((colrel 1) (colinc 1)) params + `(format-relative-tab stream ,colrel ,colinc)) + (expand-bind-defaults ((colnum 1) (colinc 1)) params + `(format-absolute-tab stream ,colnum ,colinc))))) + +(def-format-directive #\_ (colonp atsignp params) + (expand-bind-defaults () params + `(pprint-newline ,(if colonp + (if atsignp + :mandatory + :fill) + (if atsignp + :miser + :linear)) + stream))) + +(def-format-directive #\I (colonp atsignp params) + (check-modifier "at-sign" atsignp) + (expand-bind-defaults ((n 0)) params + `(pprint-indent ,(if colonp :current :block) ,n stream))) + +;;;; format directive for ~* + +(def-format-directive #\* (colonp atsignp params end) + (check-modifier '("colon" "at-sign") (and colonp atsignp)) + (flet ((make-lose (index) + `(format-error-at + ,*default-format-error-control-string* ,(1- end) + "Index ~W is out of bounds. It should have been between ~ + 0 and ~W." + ,index (length orig-args)))) + (if atsignp + (expand-bind-defaults ((posn 0)) params + (unless *orig-args-available* + (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*") + (throw 'need-orig-args nil)) + `(if (<= 0 ,posn (length orig-args)) + (setf args (nthcdr ,posn orig-args)) + ,(make-lose posn))) + (if colonp + (expand-bind-defaults ((n 1)) params + (unless *orig-args-available* + (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*") + (throw 'need-orig-args nil)) + `(do ((cur-posn 0 (1+ cur-posn)) + (arg-ptr orig-args (cdr arg-ptr))) + ((eq arg-ptr args) + (let ((new-posn (- cur-posn ,n))) + (if (<= 0 new-posn (length orig-args)) + (setf args (nthcdr new-posn orig-args)) + ,(make-lose 'new-posn)))))) + (if params + (expand-bind-defaults ((n 1)) params + (setf *only-simple-args* nil) + `(dotimes (i ,n) + ,(expand-next-arg))) + (expand-next-arg)))))) + +;;;; format directive for indirection + +(def-format-directive #\? (colonp atsignp params string end) + (check-modifier "colon" colonp) + (expand-bind-defaults () params + `(handler-bind + ((format-error + (lambda (condition) + (error 'format-error + :complaint + "~A~%while processing indirect format string:" + :args (list condition) + :print-banner nil + :control-string ,string + :offset ,(1- end))))) + ,(if atsignp + (if *orig-args-available* + `(setf args (%format stream ,(expand-next-arg) orig-args args)) + (throw 'need-orig-args nil)) + `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) + +;;;; format directives for capitalization + +(def-complex-format-directive #\( (colonp atsignp params directives) + (let* ((close (or (find-directive directives #\) nil) + (format-error "No corresponding close parenthesis"))) + (posn (position close directives)) + (before (subseq directives 0 posn)) + (after (nthcdr (1+ posn) directives))) + (values + (expand-bind-defaults () params + `(let ((stream (make-case-frob-stream stream + ,(if colonp + (if atsignp + :upcase + :capitalize) + (if atsignp + :capitalize-first + :downcase))))) + ,@(expand-directive-list before))) + after))) + +(def-complex-format-directive #\) () + (format-error "No corresponding open parenthesis")) + +;;;; format directives and support functions for conditionalization + +(def-complex-format-directive #\[ (colonp atsignp params directives) + (check-modifier '("colon" "at-sign") (and colonp atsignp)) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (values + (cond + (atsignp + (when (cdr sublists) + (format-error "Can only specify one section")) + (expand-bind-defaults () params + (expand-maybe-conditional (car sublists)))) + (colonp + (unless (= (length sublists) 2) + (format-error "Must specify exactly two sections")) + (expand-bind-defaults () params + (apply #'expand-true-false-conditional sublists))) + (t + (expand-bind-defaults ((index nil)) params + (setf *only-simple-args* nil) + (let ((clauses nil) + (case-sym (gensym)) + (case `(or ,index ,(expand-next-arg)))) + (when last-semi-with-colon-p + (push `(t ,@(expand-directive-list (pop sublists))) + clauses)) + (let ((count (length sublists))) + (dolist (sublist sublists) + (push `(,(decf count) + ,@(expand-directive-list sublist)) + clauses))) + `(let ((,case-sym ,case)) + (unless (integerp ,case-sym) + (format-error-at + ,*default-format-error-control-string* + ,*default-format-error-offset* + "The argument to ~~[ is not an integer: ~A" ,case-sym)) + (case ,case-sym ,@clauses)))))) + remaining))) + +(defun parse-conditional-directive (directives) + (let ((sublists nil) + (last-semi-with-colon-p nil) + (remaining directives)) + (loop + (let* ((close-or-semi (or (find-directive remaining #\] t) + (format-error "No corresponding close bracket"))) + (posn (position close-or-semi remaining))) + (push (subseq remaining 0 posn) sublists) + (setf remaining (nthcdr (1+ posn) remaining)) + (when (char= (directive-character close-or-semi) #\]) + (return)) + (setf last-semi-with-colon-p + (directive-colonp close-or-semi)))) + (values sublists last-semi-with-colon-p remaining))) + +(defun expand-maybe-conditional (sublist) + (flet ((hairy () + `(let ((prev-args args) + (arg ,(expand-next-arg))) + (when arg + (setf args prev-args) + ,@(expand-directive-list sublist))))) + (if *only-simple-args* + (multiple-value-bind (guts new-args) + (let ((*simple-args* *simple-args*)) + (values (expand-directive-list sublist) + *simple-args*)) + (cond ((and new-args (eq *simple-args* (cdr new-args))) + (setf *simple-args* new-args) + `(when ,(caar new-args) + ,@guts)) + (t + (setf *only-simple-args* nil) + (hairy)))) + (hairy)))) + +(defun expand-true-false-conditional (true false) + (let ((arg (expand-next-arg))) + (flet ((hairy () + `(if ,arg + (progn + ,@(expand-directive-list true)) + (progn + ,@(expand-directive-list false))))) + (if *only-simple-args* + (multiple-value-bind (true-guts true-args true-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list true) + *simple-args* + *only-simple-args*)) + (multiple-value-bind (false-guts false-args false-simple) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list false) + *simple-args* + *only-simple-args*)) + (if (= (length true-args) (length false-args)) + `(if ,arg + (progn + ,@true-guts) + ,(do ((false false-args (cdr false)) + (true true-args (cdr true)) + (bindings nil (cons `(,(caar false) ,(caar true)) + bindings))) + ((eq true *simple-args*) + (setf *simple-args* true-args) + (setf *only-simple-args* + (and true-simple false-simple)) + (if bindings + `(let ,bindings + ,@false-guts) + `(progn + ,@false-guts))))) + (progn + (setf *only-simple-args* nil) + (hairy))))) + (hairy))))) + +(def-complex-format-directive #\; () + (format-error + "~~; directive not contained within either ~~[...~~] or ~~<...~~>")) + +(def-complex-format-directive #\] () + (format-error "No corresponding open bracket")) + +;;;; format directive for up-and-out + +(def-format-directive #\^ (colonp atsignp params) + (check-modifier "at-sign" atsignp) + (when (and colonp (not *up-up-and-out-allowed*)) + (format-error "Attempt to use ~~:^ outside a ~~:{...~~} construct")) + `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params + `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3)) + (,arg2 (eql ,arg1 ,arg2)) + (,arg1 (eql ,arg1 0)) + (t ,(if colonp + '(null outside-args) + (progn + (setf *only-simple-args* nil) + '(null args)))))) + ,(if colonp + '(return-from outside-loop nil) + '(return)))) + +;;;; format directives for iteration + +(def-complex-format-directive #\{ (colonp atsignp params string end directives) + (let* ((close (or (find-directive directives #\} nil) + (format-error "No corresponding close brace"))) + (closed-with-colon (directive-colonp close)) + (posn (position close directives))) + (labels + ((compute-insides () + (if (zerop posn) + (if *orig-args-available* + `((handler-bind + ((format-error + (lambda (condition) + (format-error-at* + ,string ,(1- end) + "~A~%while processing indirect format string:" + (list condition) + :print-banner nil)))) + (setf args + (%format stream inside-string orig-args args)))) + (throw 'need-orig-args nil)) + (let ((*up-up-and-out-allowed* colonp)) + (expand-directive-list (subseq directives 0 posn))))) + (compute-loop (count) + (when atsignp + (setf *only-simple-args* nil)) + `(loop + ,@(unless closed-with-colon + '((when (null args) + (return)))) + ,@(when count + `((when (and ,count (minusp (decf ,count))) + (return)))) + ,@(if colonp + (let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + `((let* ((orig-args ,(expand-next-arg)) + (outside-args args) + (args orig-args)) + (declare (ignorable orig-args outside-args args)) + (block nil + ,@(compute-insides))))) + (compute-insides)) + ,@(when closed-with-colon + '((when (null args) + (return)))))) + (compute-block (count) + (if colonp + `(block outside-loop + ,(compute-loop count)) + (compute-loop count))) + (compute-bindings (count) + (if atsignp + (compute-block count) + `(let* ((orig-args ,(expand-next-arg)) + (args orig-args)) + (declare (ignorable orig-args args)) + ,(let ((*expander-next-arg-macro* 'expander-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) + (compute-block count)))))) + (values (if params + (expand-bind-defaults ((count nil)) params + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings count)) + (compute-bindings count))) + (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings nil)) + (compute-bindings nil))) + (nthcdr (1+ posn) directives))))) + +(def-complex-format-directive #\} () + (format-error "No corresponding open brace")) + +;;;; format directives and support functions for justification + +(defconstant-eqx !illegal-inside-justification + '#.(mapcar (lambda (x) (directive-bits (parse-directive x 0 nil))) + '("~:>" "~:@>" + "~:T" "~:@T")) + #'equal) + +;;; Reject ~W, ~_, ~I and certain other specific values of modifier+character. +(defun illegal-inside-justification-p (directive) + (and (format-directive-p directive) + (if (or (member (directive-bits directive) !illegal-inside-justification) + (member (directive-character directive) '(#\W #\I #\_))) + t + nil))) + +(def-complex-format-directive #\< (colonp atsignp params string end directives) + (multiple-value-bind (segments first-semi close remaining) + (parse-format-justification directives) + (values + (if (directive-colonp close) ; logical block vs. justification + (multiple-value-bind (prefix per-line-p insides suffix) + (parse-format-logical-block segments colonp first-semi + close params string end) + (expand-format-logical-block prefix per-line-p insides + suffix atsignp)) + (let ((count (reduce #'+ (mapcar (lambda (x) + (count-if #'illegal-inside-justification-p x)) + segments)))) + (when (> count 0) + ;; ANSI specifies that "an error is signalled" in this + ;; situation. + (format-error* + "~D illegal directive~:P found inside justification block" + (list count) + :references '((:ansi-cl :section (22 3 5 2))))) + ;; ANSI does not explicitly say that an error should be + ;; signalled, but the @ modifier is not explicitly allowed + ;; for ~> either. + (when (directive-atsignp close) + (format-error-at* + nil (1- (directive-end close)) + "@ modifier not allowed in close directive of ~ + justification block (i.e. ~~<...~~@>." + '() + :references '((:ansi-cl :section (22 3 6 2))))) + (expand-format-justification segments colonp atsignp + first-semi params))) + remaining))) + +(def-complex-format-directive #\> () + (format-error "No corresponding open bracket")) + +(defun parse-format-logical-block + (segments colonp first-semi close params string end) + (when params + (format-error-at nil (caar params) + "No parameters can be supplied with ~~<...~~:>.")) + (multiple-value-bind (prefix insides suffix) + (multiple-value-bind (prefix-default suffix-default) + (if colonp (values "(" ")") (values "" "")) + (flet ((extract-string (list prefix-p) + (let ((directive (find-if #'format-directive-p list))) + (if directive + (format-error-at* + nil (1- (directive-end directive)) + "Cannot include format directives inside the ~ + ~:[suffix~;prefix~] segment of ~~<...~~:>" + (list prefix-p) + :references '((:ansi-cl :section (22 3 5 2)))) + (apply #'concatenate 'string list))))) + (case (length segments) + (0 (values prefix-default nil suffix-default)) + (1 (values prefix-default (car segments) suffix-default)) + (2 (values (extract-string (car segments) t) + (cadr segments) suffix-default)) + (3 (values (extract-string (car segments) t) + (cadr segments) + (extract-string (caddr segments) nil))) + (t + (format-error "Too many segments for ~~<...~~:>"))))) + (when (directive-atsignp close) + (setf insides + (add-fill-style-newlines insides + string + (if first-semi + (directive-end first-semi) + end)))) + (values prefix + (and first-semi (directive-atsignp first-semi)) + insides + suffix))) + +(defun add-fill-style-newlines (list string offset &optional last-directive) + (cond + (list + (let ((directive (car list))) + (cond + ((simple-string-p directive) + (let* ((non-space (position #\Space directive :test #'char/=)) + (newlinep (and last-directive + (char= (directive-character last-directive) + #\Newline)))) + (cond + ((and newlinep non-space) + (nconc + (list (subseq directive 0 non-space)) + (add-fill-style-newlines-aux + (subseq directive non-space) string (+ offset non-space)) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (newlinep + (cons directive + (add-fill-style-newlines + (cdr list) string (+ offset (length directive))))) + (t + (nconc (add-fill-style-newlines-aux directive string offset) + (add-fill-style-newlines + (cdr list) string (+ offset (length directive)))))))) + (t + (cons directive + (add-fill-style-newlines + (cdr list) string + (directive-end directive) directive)))))) + (t nil))) + +(defun add-fill-style-newlines-aux (literal string offset) + (let ((end (length literal)) + (posn 0)) + (collect ((results)) + (loop + (let ((blank (position #\space literal :start posn))) + (when (null blank) + (results (subseq literal posn)) + (return)) + (let ((non-blank (or (position #\space literal :start blank + :test #'char/=) + end))) + (results (subseq literal posn non-blank)) + (results (make-format-directive + string (+ offset non-blank) (+ offset non-blank) + nil t nil #\_ nil)) ; params,colon,atsign,char,symbol + (setf posn non-blank)) + (when (= posn end) + (return)))) + (results)))) + +(defun parse-format-justification (directives) + (let ((first-semi nil) + (close nil) + (remaining directives)) + (collect ((segments)) + (loop + (let ((close-or-semi (or (find-directive remaining #\> t) + (format-error "No corresponding close bracket")))) + (let ((posn (position close-or-semi remaining))) + (segments (subseq remaining 0 posn)) + (setf remaining (nthcdr (1+ posn) remaining))) + (when (char= (directive-character close-or-semi) #\>) + (setf close close-or-semi) + (return)) + (unless first-semi + (setf first-semi close-or-semi)))) + (values (segments) first-semi close remaining)))) + +(sb-xc:defmacro expander-pprint-next-arg (string offset) + `(progn + (when (null args) + (format-error-at ,string ,offset "No more arguments")) + (pprint-pop) + (pop args))) + +(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) + `(let ((arg ,(if atsignp 'args (expand-next-arg)))) + ,@(when atsignp + (setf *only-simple-args* nil) + '((setf args nil))) + (pprint-logical-block + (stream arg + ,(if per-line-p :per-line-prefix :prefix) ,prefix + :suffix ,suffix) + (let ((args arg) + ,@(unless atsignp + `((orig-args arg)))) + (declare (ignorable args ,@(unless atsignp '(orig-args)))) + (block nil + ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) + (*only-simple-args* nil) + (*orig-args-available* + (if atsignp *orig-args-available* t))) + (expand-directive-list insides))))))) + +(defun expand-format-justification (segments colonp atsignp first-semi params) + (let ((newline-segment-p + (and first-semi + (directive-colonp first-semi)))) + (expand-bind-defaults + ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + params + `(let ((segments nil) + ,@(when newline-segment-p + '((newline-segment nil) + (extra-space 0) + (line-len 72)))) + (block nil + ,@(when newline-segment-p + `((setf newline-segment + (%with-output-to-string (stream) + ,@(expand-directive-list (pop segments)))) + ,(expand-bind-defaults + ((extra 0) + (line-len '(or (sb-impl::line-length stream) 72))) + (directive-params first-semi) + `(setf extra-space ,extra line-len ,line-len)))) + ,@(mapcar (lambda (segment) + `(push (%with-output-to-string (stream) + ,@(expand-directive-list segment)) + segments)) + segments)) + (format-justification stream + ,@(if newline-segment-p + '(newline-segment extra-space line-len) + '(nil 0 0)) + segments ,colonp ,atsignp + ,mincol ,colinc ,minpad ,padchar))))) + +;;;; format directive and support function for user-defined method + +(def-format-directive #\/ (string start end colonp atsignp params) + (let ((symbol (extract-user-fun-name string start end))) + (collect ((param-names) (bindings)) + (dolist (param-and-offset params) + (let ((param (cdr param-and-offset))) + (let ((param-name (sb-xc:gensym "PARAM"))) + (param-names param-name) + (bindings `(,param-name + ,(case param + (:arg (expand-next-arg)) + (:remaining '(length args)) + (t param))))))) + `(let ,(bindings) + (,symbol stream ,(expand-next-arg) ,colonp ,atsignp + ,@(param-names)))))) + +(defun extract-user-fun-name (string start end) + ;; Searching backwards avoids finding the wrong slash in a funky string + ;; such as "~'/,'//fun/" which passes #\/ twice to FUN as parameters. + (let* ((slash (or (position #\/ string :start start :end (1- end) + :from-end t) + (format-error "Malformed ~~/ directive"))) + (name (nstring-upcase (subseq string (1+ slash) (1- end)))) + (first-colon (position #\: name)) + (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) + (symbol + (cond ((and second-colon (= second-colon (1+ first-colon))) + (subseq name (1+ second-colon))) + (first-colon + (subseq name (1+ first-colon))) + (t name))) + (package + (if (not first-colon) + #.(find-package "COMMON-LISP-USER") + (let ((package-name (subseq name 0 first-colon))) + (or (find-package package-name) + ;; FIXME: should be PACKAGE-ERROR? Could we just + ;; use FIND-UNDELETED-PACKAGE-OR-LOSE? + (format-error "No package named ~S" package-name)))))) + (intern symbol package))) + +(defun extract-user-fun-directives (string) + (let* ((tokens (handler-case + (combine-directives + (%tokenize-control-string string 0 (length string) nil) + nil) + (error (e) + (declare (ignore e)) + (return-from extract-user-fun-directives (values nil nil))))) + (max-len (loop for token in tokens + sum (if (format-directive-p token) + (- (directive-end token) (directive-start token)) + (length token)))) + (new-string + (make-array max-len :element-type 'character :fill-pointer 0)) + (symbols)) + (dolist (token tokens) + (cond ((stringp token) + (aver (not (find #\~ token))) + (let ((new-start (fill-pointer new-string))) + (incf (fill-pointer new-string) (length token)) + (replace new-string token :start1 new-start))) + (t + (let* ((start (directive-start token)) + (end (directive-end token)) + (len (- end start)) + (new-start (fill-pointer new-string))) + (cond ((eql (directive-character token) #\/) + (push (handler-case (extract-user-fun-name string start end) + (error (e) + (declare (ignore e)) + (return-from extract-user-fun-directives + (values nil nil)))) + symbols) + ;; Don't copy past the first slash. Scan backwards for it + ;; exactly as is done in EXTRACT-USER-FUN-NAME above. + ;; This error can't really happen (as we've already produced + ;; a valid tokenization), but the error check avoids + ;; a warning about adding 1 to NIL. + (setq end (1+ (or (position #\/ string :start start :end (1- end) + :from-end t) + (error "Malformed ~~/ directive")))) + ;; compute new length to copy, +1 is for trailing slash + (incf (fill-pointer new-string) (1+ (- end start))) + (setf (char new-string (1- (fill-pointer new-string))) #\/)) + (t + (incf (fill-pointer new-string) len))) + (replace new-string string :start1 new-start + :start2 start :end2 end))))) + (values (nreverse symbols) + (possibly-base-stringize new-string)))) + +(push '("SB-FORMAT" tokens) *!removable-symbols*) +(sb-xc:defmacro tokens (string) + (declare (string string)) + (multiple-value-bind (symbols new-string) (extract-user-fun-directives string) + (if symbols + (make-fmt-control-proxy new-string symbols) + (possibly-base-stringize new-string)))) + +;;; compile-time checking for argument mismatch. This code is +;;; inspired by that of Gerd Moellmann, and comes decorated with +;;; FIXMEs: +(defun %compiler-walk-format-string (string args) + (let* ((string (coerce string 'simple-string)) + (*default-format-error-control-string* string)) + (macrolet ((incf-both (&optional (increment 1)) + `(progn + (incf min ,increment) + (incf max ,increment))) + (walk-complex-directive (function) + `(multiple-value-bind (min-inc max-inc remaining) + (,function directive directives args) + (incf min min-inc) + (incf max max-inc) + (setq directives remaining)))) + ;; FIXME: these functions take a list of arguments as well as + ;; the directive stream. This is to enable possibly some + ;; limited type checking on FORMAT's arguments, as well as + ;; simple argument count mismatch checking: when the minimum and + ;; maximum argument counts are the same at a given point, we + ;; know which argument is going to be used for a given + ;; directive, and some (annotated below) require arguments of + ;; particular types. + (labels + ((walk-justification (justification directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (directive-end justification)))) + (multiple-value-bind (segments first-semi close remaining) + (parse-format-justification directives) + (declare (ignore segments first-semi)) + (cond + ((not (directive-colonp close)) + (values 0 0 directives)) + ((directive-atsignp justification) + (values 0 call-arguments-limit directives)) + ;; FIXME: here we could assert that the + ;; corresponding argument was a list. + (t (values 1 1 remaining)))))) + (walk-conditional (conditional directives args) + (let ((*default-format-error-offset* + (1- (directive-end conditional)))) + (multiple-value-bind (sublists last-semi-with-colon-p remaining) + (parse-conditional-directive directives) + (declare (ignore last-semi-with-colon-p)) + (let ((sub-max + (loop for s in sublists + maximize (nth-value + 1 (walk-directive-list s args))))) + (cond + ((directive-atsignp conditional) + (values 1 (max 1 sub-max) remaining)) + ((loop for p in (directive-params conditional) + thereis (or (integerp (cdr p)) + (memq (cdr p) '(:remaining :arg)))) + (values 0 sub-max remaining)) + ;; FIXME: if not COLONP, then the next argument + ;; must be a number. + (t (values 1 (1+ sub-max) remaining))))))) + (walk-iteration (iteration directives args) + (declare (ignore args)) + (let ((*default-format-error-offset* + (1- (directive-end iteration)))) + (let* ((close (find-directive directives #\} nil)) + (posn (or (position close directives) + (format-error "No corresponding close brace"))) + (remaining (nthcdr (1+ posn) directives))) + ;; FIXME: if POSN is zero, the next argument must be + ;; a format control (either a function or a string). + (if (directive-atsignp iteration) + (values (if (zerop posn) 1 0) + call-arguments-limit + remaining) + ;; FIXME: the argument corresponding to this + ;; directive must be a list. + (let ((nreq (if (zerop posn) 2 1))) + (values nreq nreq remaining)))))) + (walk-directive-list (directives args) + (let ((min 0) (max 0)) + (loop + (let ((directive (pop directives))) + (when (null directive) + (return (values min (min max call-arguments-limit)))) + (when (format-directive-p directive) + (incf-both (count :arg (directive-params directive) + :key #'cdr)) + (let ((c (directive-character directive))) + (cond + ((find c "ABCDEFGORSWX$/") + (incf-both)) + ((char= c #\P) + (unless (directive-colonp directive) + (incf-both))) + ((or (find c "IT%&|_();>~") (char= c #\Newline))) + ;; FIXME: check correspondence of ~( and ~) + ((char= c #\<) + (walk-complex-directive walk-justification)) + ((char= c #\[) + (walk-complex-directive walk-conditional)) + ((char= c #\{) + (walk-complex-directive walk-iteration)) + ((char= c #\?) + ;; FIXME: the argument corresponding to this + ;; directive must be a format control. + (cond + ((directive-atsignp directive) + (incf min) + (setq max call-arguments-limit)) + (t (incf-both 2)))) + (t (throw 'give-up-format-string-walk nil)))))))))) + (catch 'give-up-format-string-walk + (let ((directives (tokenize-control-string string))) + (walk-directive-list directives args))))))) + +;;; Optimize common case of constant keyword arguments +;;; to WRITE and WRITE-TO-STRING +(flet + ((expand (fn object keys) + (do (streamvar bind ignore) + ((or (atom keys) (atom (cdr keys))) + (if keys ; fail + (values nil t) + (values + (let* ((objvar (copy-symbol 'object)) + (bind `((,objvar ,object) ,@(nreverse bind))) + (ignore (when ignore `((declare (ignore ,@ignore)))))) + (case fn + (write + ;; When :STREAM was specified, this used to insert a call + ;; to (OUT-SYNONYM-OF STREAMVAR) which added junk to the + ;; expansion which was not likely to improve performance. + ;; The benefit of this transform is that it avoids runtime + ;; keyword parsing and binding of 16 specials vars, *not* + ;; that it can inline testing for T or NIL as the stream. + `(let ,bind ,@ignore + ,@(if streamvar + `((%write ,objvar ,streamvar)) + `((output-object ,objvar *standard-output*) + ,objvar)))) + (write-to-string + (if (cdr bind) + `(let ,bind ,@ignore (stringify-object ,objvar)) + `(stringify-object ,object))))) + nil))) + (let* ((key (pop keys)) + (value (pop keys)) + (variable + (cond ((getf '(:array *print-array* + :base *print-base* + :case *print-case* + :circle *print-circle* + :escape *print-escape* + :gensym *print-gensym* + :length *print-length* + :level *print-level* + :lines *print-lines* + :miser-width *print-miser-width* + :pprint-dispatch *print-pprint-dispatch* + :pretty *print-pretty* + :radix *print-radix* + :readably *print-readably* + :right-margin *print-right-margin* + :suppress-errors *suppress-print-errors*) + key)) + ((and (eq key :stream) (eq fn 'write)) + (or streamvar (setq streamvar (copy-symbol 'stream)))) + (t + (return (values nil t)))))) + (when (assoc variable bind) + ;; First key has precedence, but we still need to execute the + ;; argument, and in the right order. + (setf variable (gensym "IGNORE")) + (push variable ignore)) + (push (list variable value) bind))))) + + (sb-c:define-source-transform write (object &rest keys) + (expand 'write object keys)) + + (sb-c:define-source-transform write-to-string (object &rest keys) + (expand 'write-to-string object keys))) + +#-sb-xc-host +(defun !late-format-init () + (setq sb-format::**tokenize-control-string-cache-vector** nil)) diff -Nru sbcl-2.1.1/src/code/full-eval.lisp sbcl-2.1.11/src/code/full-eval.lisp --- sbcl-2.1.1/src/code/full-eval.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/full-eval.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -77,8 +77,8 @@ :format-arguments format-arguments)) (defmacro nconc-2 (a b) - (let ((tmp (gensym)) - (tmp2 (gensym))) + (let ((tmp (sb-xc:gensym)) + (tmp2 (sb-xc:gensym))) `(let ((,tmp ,a) (,tmp2 ,b)) (if ,tmp @@ -323,14 +323,20 @@ (let*-like-bindings nil)) (cond ((< arguments-present required-length) - (ip-error "~@" + (ip-error (sb-format:tokens + "~@") arguments lambda-list)) ((and (not (or rest-p keyword-p)) keywords-present-p) - (ip-error "~@" + (ip-error (sb-format:tokens + "~@") arguments lambda-list)) ((and keyword-p keywords-present-p (oddp (- arguments-present non-keyword-arguments))) - (ip-error "~@" + (ip-error (sb-format:tokens + "~@") arguments lambda-list))) (dotimes (i required-length) (push (cons (pop required) (pop arguments)) let-like-bindings)) @@ -356,7 +362,9 @@ (loop for (key value) on keyword-plist by #'cddr doing (when (and (not (eq key :allow-other-keys)) (not (member key keyword :key #'keyword-key))) - (ip-error "~@" + (ip-error (sb-format:tokens + "~@") key original-arguments lambda-list)))) (dolist (keyword-spec keyword) (let ((supplied (getf keyword-plist (keyword-key keyword-spec) diff -Nru sbcl-2.1.1/src/code/function-names.lisp sbcl-2.1.11/src/code/function-names.lisp --- sbcl-2.1.1/src/code/function-names.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/function-names.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1,7 +1,7 @@ (in-package "SB-IMPL") ;;;; generalized function names -(!define-load-time-global *valid-fun-names-alist* nil) +(define-load-time-global *valid-fun-names-alist* nil) (defun %define-fun-name-syntax (symbol checker) (let ((found (assoc symbol *valid-fun-names-alist* :test #'eq))) @@ -10,12 +10,6 @@ (setq *valid-fun-names-alist* (acons symbol checker *valid-fun-names-alist*))))) -#+sb-xc-host -(setf (get '%define-fun-name-syntax :sb-cold-funcall-handler/for-effect) - (lambda (symbol checker) - (cold-target-push (cold-cons (cold-intern symbol) checker) - '*valid-fun-names-alist*))) - (defmacro define-function-name-syntax (symbol (var) &body body) "Define function names of the form of a list headed by SYMBOL to be a legal function name, subject to restrictions imposed by BODY. BODY @@ -60,8 +54,15 @@ (cons (unless (member (car fun) '(cas setf)) (valid-function-name-p fun)))))))) -;; CAS and SETF names should have in common the aspect that -;; (CAS (CAS BAZ)), (SETF (CAS BAZ)), (CAS (SETF BAZ)) are not reasonable. -;; 'cas.lisp' doesn't need to know this technique for sharing the parser, -;; so the name syntax is defined here instead of there. -(%define-fun-name-syntax 'cas #'%check-setf-fun-name) +;;; FBOUNDP wants to know what names are valid early on in COLD-INIT. +(defun !function-names-init () + (setq *valid-fun-names-alist* nil) + ;; CAS and SETF names should have in common the aspect that + ;; (CAS (CAS BAZ)), (SETF (CAS BAZ)), (CAS (SETF BAZ)) are not reasonable. + ;; 'cas.lisp' doesn't need to know this technique for sharing the parser, + ;; so the name syntax is defined here instead of there. + (%define-fun-name-syntax 'setf #'%check-setf-fun-name) + (%define-fun-name-syntax 'cas #'%check-setf-fun-name)) + +#+sb-xc-host +(!function-names-init) diff -Nru sbcl-2.1.1/src/code/gc.lisp sbcl-2.1.11/src/code/gc.lisp --- sbcl-2.1.1/src/code/gc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/gc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -77,10 +77,31 @@ and submit it as a patch." (+ (dynamic-usage) *n-bytes-freed-or-purified*)) + +;;; * If symbols are 7 words incl header, as they are on 32-bit w/threads, +;;; then the part of NIL that manifests as symbol slots consumes 6 words +;;; (less the header) because NIL's symbol widetag precedes it by 1 word. +;;; So, there are 6 post-header words and 2 pre-header: one containing +;;; the widetag (not that it is ever read), and one 0 word. +;;; * If symbols are 6 words incl header, as they are on 64-bit and +;;; 32-bit w/o threads, then the symbol-like part of NIL is 5 words, +;;; which aligns up to 6, plus the two pre-header words. +;;; So either way, NIL's alignment padding makes it come out to 8 words in total. +(defconstant sb-vm::sizeof-nil-in-words (+ 2 (sb-int:align-up (1- sb-vm:symbol-size) 2))) + +(defun primitive-object-size (object) + "Return number of bytes of heap or stack directly consumed by OBJECT" + (cond ((not (sb-vm:is-lisp-pointer (get-lisp-obj-address object))) 0) + ((eq object nil) (ash sb-vm::sizeof-nil-in-words sb-vm:word-shift)) + ((simple-fun-p object) (code-object-size (fun-code-header object))) + (t + (with-alien ((sizer (function unsigned unsigned) :extern "primitive_object_size")) + (with-pinned-objects (object) + (alien-funcall sizer (get-lisp-obj-address object))))))) ;;;; GC hooks -(!define-load-time-global *after-gc-hooks* nil +(define-load-time-global *after-gc-hooks* nil "Called after each garbage collection, except for garbage collections triggered during thread exits. In a multithreaded environment these hooks may run in any thread.") @@ -374,7 +395,7 @@ (extern-alien "bytes_consed_between_gcs" os-vm-size-t)) (defun (setf bytes-consed-between-gcs) (val) - (declare (type index val)) + (declare (type (and fixnum unsigned-byte) val)) (setf (extern-alien "bytes_consed_between_gcs" os-vm-size-t) val)) diff -Nru sbcl-2.1.1/src/code/globals.lisp sbcl-2.1.11/src/code/globals.lisp --- sbcl-2.1.1/src/code/globals.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/globals.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -37,17 +37,10 @@ docstring) `(locally (declare (notinline (setf info))) - ;; This initial value expression is a mite confusing. - ;; Most thread-locals that we use are of the :ALWAYS-BOUNDP kind, and since the - ;; value is stuffed in the moment a thread is created, no value is ever needed here, - ;; because this value form is evaluated exactly once (in cold-init) and never again. - ;; But if not always bound, we have a problem: INIT-THREAD-LOCAL-STORAGE writes - ;; an unbound marker, which makes this DEFVAR want to compute something. - ;; But that "something" has to be the unbound marker. - (defvar ,name ,(if always-boundp - `(error "~S had no value in cold-init" ',name) - initform) - ,docstring) + ;; We don't error here on ALWAYS-BOUND variables as they may have + ;; variable reference initforms that aren't initialized until + ;; later in cold-init. + (defvar ,name ,initform ,docstring) ;; :EXECUTE is for parallelized make-host-2 to see the compile-toplevel effect (eval-when (:compile-toplevel :execute) (%define-thread-local ',name ',initform ',always-boundp)) @@ -65,8 +58,7 @@ (let ((found (assq symbol (cdr list)))) (if found (setf (cadr found) initform) - (let* ((thread-struct (find 'sb-vm::thread sb-vm:*primitive-objects* - :key #'sb-vm:primitive-object-name)) + (let* ((thread-struct (sb-vm::primitive-object 'sb-vm::thread)) (n-fixed (+ (sb-vm:primitive-object-length thread-struct) (count-if-not (lambda (x) @@ -84,7 +76,7 @@ ;;; by RESTART-BIND. (define-thread-local *restart-clusters* nil) -(!define-load-time-global sb-kernel::**initial-handler-clusters** '(nil)) +(define-load-time-global sb-kernel::**initial-handler-clusters** '(nil)) ;;; a list of handlers maintained by HANDLER-BIND (define-thread-local *handler-clusters* sb-kernel::**initial-handler-clusters**) diff -Nru sbcl-2.1.1/src/code/hash-table.lisp sbcl-2.1.11/src/code/hash-table.lisp --- sbcl-2.1.1/src/code/hash-table.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/hash-table.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -134,8 +134,8 @@ ;; next GC. (hash-fun nil :type function :read-only t) - ;; The type of hash table this is. Only used for printing and as - ;; part of the exported interface. + ;; The type of hash table this is. Part of the exported interface, + ;; as well as needed for the MAKE-LOAD-FORM and PRINT-OBJECT methods. (test nil :type symbol :read-only t) ;; How much to grow the hash table by when it fills up. If an index, ;; then add that amount. If a floating point number, then multiply @@ -180,14 +180,7 @@ ;; List of values (i.e. the second half of the k/v pair) culled out during ;; GC, used only by the finalizer hash-table. This informs Lisp of the IDs ;; (small fixnums) of the finalizers that need to run. - (culled-values nil :type list) - ;; For detecting concurrent accesses. - #+sb-hash-table-debug - (signal-concurrent-access t :type (member nil t)) - #+sb-hash-table-debug - (reading-thread nil) - #+sb-hash-table-debug - (writing-thread nil)) + (culled-values nil :type list)) (sb-xc:defmacro hash-table-lock (table) `(let ((ht ,table)) (or (hash-table-%lock ht) (install-hash-table-lock ht)))) diff -Nru sbcl-2.1.1/src/code/host-pprint.lisp sbcl-2.1.11/src/code/host-pprint.lisp --- sbcl-2.1.1/src/code/host-pprint.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/host-pprint.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -22,7 +22,7 @@ (:predicate nil)) ;; A list of all the entries (except for CONS entries below) in highest ;; to lowest priority. - (entries nil :type list) + (entries #() :type simple-vector) ;; A hash table mapping things to entries for type specifiers of the ;; form (CONS (MEMBER )). If the type specifier is of this form, ;; we put it in this hash table instead of the regular entries table. @@ -33,7 +33,3 @@ (only-initial-entries nil :type boolean)) (declaim (freeze-type pprint-dispatch-table)) - -#+sb-xc -(defmethod print-object ((table pprint-dispatch-table) stream) - (print-unreadable-object (table stream :type t :identity t))) diff -Nru sbcl-2.1.1/src/code/icf.lisp sbcl-2.1.11/src/code/icf.lisp --- sbcl-2.1.1/src/code/icf.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/icf.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -25,6 +25,7 @@ ;;; Return T if any pointers were replaced in a code object. (defun apply-forwarding-map (map print &aux any-change) + (declare (optimize (sb-c::aref-trapping 0))) (when print (let ((*print-pretty* nil)) (dohash ((k v) map) @@ -47,22 +48,19 @@ (lambda (object widetag size &aux touchedp) (declare (ignore size)) (macrolet ((rewrite (place &aux (accessor (if (listp place) (car place)))) - ;; These two slots have no setters, but nor are + ;; SYMBOL-NAME and SYMBOL-PACKAGE have no setters, but nor are ;; they possibly affected by code folding. - (unless (member accessor '(symbol-name symbol-package)) + ;; {%INSTANCE,%FUN}-LAYOUT have setters but they are not spelled + ;; SETF, nor are they affected by code folding. + (unless (member accessor '(symbol-name symbol-package + %fun-layout %instance-layout)) `(let* ((oldval ,place) (newval (forward oldval))) (unless (eq newval oldval) ,(case accessor (data-vector-ref `(setf (svref ,@(cdr place)) newval touchedp t)) (value-cell-ref - ;; pinned already because we're iterating over the heap - ;; which disables GC, but maybe some day it won't. - `(with-pinned-objects (object) - (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address object)) - (- (ash value-cell-value-slot word-shift) - other-pointer-lowtag)) - newval))) + `(%primitive value-cell-set object newval)) (weak-pointer-value ;; Preserve gencgc invariant that a weak pointer ;; can't point to an object younger than itself. @@ -73,12 +71,10 @@ #+nil (warn "Can't update weak pointer ~s" object)) (t - (with-pinned-objects (object) - (setf (sap-ref-lispobj - (int-sap (get-lisp-obj-address object)) - (- (ash weak-pointer-value-slot word-shift) - other-pointer-lowtag)) - newval))))) + (%primitive set-slot object newval + '(setf weak-pointer-value) + weak-pointer-value-slot + other-pointer-lowtag)))) (%primitive (ecase (cadr place) (fast-symbol-global-value @@ -114,6 +110,7 @@ (let* ((oldval (%closure-fun object)) (newval (forward oldval))) (unless (eq newval oldval) + #+nil ; FIXME: gotta figure out GC marking situation here (with-pinned-objects (object newval) (setf (sap-ref-sap (int-sap (- (get-lisp-obj-address object) fun-pointer-lowtag)) @@ -123,11 +120,7 @@ (let* ((oldval (%closure-index-ref object i)) (newval (forward oldval))) (unless (eq newval oldval) - (with-pinned-objects (object) - (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address object)) - (- (ash (+ i closure-info-offset) word-shift) - fun-pointer-lowtag)) - newval)))))) + (%closure-index-set object i newval))))) (ratio :override) ((complex rational) :override) (t diff -Nru sbcl-2.1.1/src/code/immobile-space.lisp sbcl-2.1.11/src/code/immobile-space.lisp --- sbcl-2.1.1/src/code/immobile-space.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/immobile-space.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,6 +11,7 @@ (in-package "SB-X86-64-ASM") +(eval-when (:compile-toplevel) ; not needed outside this file (defmacro do-immobile-code ((code-var) &body body) ;; Loop over all code objects `(let* ((call (find-inst #xE8 (get-inst-space))) @@ -39,7 +40,7 @@ ;; Slowness here is bothersome, especially for SB-VM::REMOVE-STATIC-LINKS, ;; so skip right over all fixedobj pages. (ash varyobj-space-start (- n-fixnum-tag-bits)) - (%make-lisp-obj (sap-int *varyobj-space-free-pointer*)))))) + (%make-lisp-obj (sap-int *varyobj-space-free-pointer*))))))) (defun sb-vm::collect-immobile-code-relocs () (let ((code-components @@ -169,8 +170,9 @@ ;; CMPXCHG is atomic even when misaligned, and x86-64 promises ;; that self-modifying code works correctly, so the fetcher ;; should never see a torn write. - (%primitive sb-vm::signed-sap-cas-32 - sap 0 oldval newval)))) + (cas (sap-ref-32 sap 0) + (ldb (byte 32 0) oldval) + (ldb (byte 32 0) newval))))) (do-immobile-code (code) ;; Examine only those code components which potentially use FDEFN. (binding* ((constant-index (code-statically-links-fdefn-p code) :exit-if-null) diff -Nru sbcl-2.1.1/src/code/inspect.lisp sbcl-2.1.11/src/code/inspect.lisp --- sbcl-2.1.1/src/code/inspect.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/inspect.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -165,7 +165,7 @@ (defun inspected-structure-elements (object) (let ((parts-list '()) - (info (layout-info (sb-kernel:layout-of object)))) + (info (wrapper-info (sb-kernel:wrapper-of object)))) (when (sb-kernel::defstruct-description-p info) (dolist (dd-slot (dd-slots info) (nreverse parts-list)) (push (cons (dsd-name dd-slot) @@ -221,7 +221,7 @@ ;; to DESCRIBE from the inspector. (list* (cons "Lambda-list" (%fun-lambda-list object)) - (cons "Ftype" (%fun-type object)) + (cons "Ftype" (%fun-ftype object)) (when (closurep object) (list (cons "Closed over values" (%closure-values object))))))) diff -Nru sbcl-2.1.1/src/code/interr.lisp sbcl-2.1.11/src/code/interr.lisp --- sbcl-2.1.1/src/code/interr.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/interr.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,8 +20,8 @@ `(progn (defconstant n-internal-error-handlers ,n) (declaim ((simple-vector ,n) **internal-error-handlers**)) - (!define-load-time-global **internal-error-handlers** - ,(make-array n :initial-element 0)))))) + (define-load-time-global **internal-error-handlers** + ,(make-array n :initial-element 0)))))) (def-it)) (defmacro deferr (name args &rest body) @@ -325,7 +325,7 @@ (if (invalid-array-p object) (invalid-array-error object) (error (if (and (%instancep object) - (layout-invalid (%instance-layout object))) + (wrapper-invalid (%instance-wrapper object))) ;; Signaling LAYOUT-INVALID is dubious, but I guess it provides slightly ;; more information in that it says that the object may have at some point ;; been TYPE. Anyway, it's not wrong - it's a subtype of TYPE-ERROR. @@ -335,8 +335,8 @@ :expected-type (typecase type (classoid-cell (classoid-cell-name type)) - (layout - (layout-proper-name type)) + (wrapper + (wrapper-proper-name type)) (t type)) :context (sb-di:error-context)))) @@ -356,10 +356,12 @@ context))) (error 'unknown-keyword-argument :name key-name)))) -;; TODO: make the arguments (ARRAY INDEX &optional BOUND) -;; and don't need the bound for vectors. Just read it. (deferr invalid-array-index-error (array bound index) (invalid-array-index-error array index bound)) +(deferr invalid-vector-index-error (vector index) + (invalid-array-index-error vector index (length vector))) +(deferr uninitialized-element-error (vector index) + (error 'uninitialized-element-error :name (cons vector index))) (deferr tls-exhausted-error () ;; There is nothing we can do about it. A number of entries in the diff -Nru sbcl-2.1.1/src/code/last-file.lisp sbcl-2.1.11/src/code/last-file.lisp --- sbcl-2.1.1/src/code/last-file.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/last-file.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -38,13 +38,15 @@ '(:extra-artifact) :target-compile) :direction :output :if-exists :supersede) (dolist (root '(structure-object function)) - (dolist (pair (sort (%hash-table-alist - (classoid-subclasses (find-classoid root))) - #'string< - ;; pair = (# . #) - :key (lambda (pair) (classoid-name (car pair))))) - (let* ((layout (cdr pair)) - (dd (layout-info layout))) + (dolist (pair (let ((subclassoids (classoid-subclasses (find-classoid root)))) + (if (listp subclassoids) + subclassoids + (sort (%hash-table-alist subclassoids) + #'string< + ;; pair = (# . #) + :key (lambda (pair) (classoid-name (car pair))))))) + (let* ((wrapper (cdr pair)) + (dd (wrapper-info wrapper))) (cond (dd (let* ((*print-pretty* nil) ; output should be insensitive to host pprint @@ -53,11 +55,10 @@ (*package* (cl:symbol-package classoid-name))) (format output "~/sb-ext:print-symbol-with-prefix/ ~S (~%" classoid-name - (list* (the (unsigned-byte 16) (layout-flags layout)) - (layout-depthoid layout) - (map 'list - (lambda (x) (classoid-name (layout-classoid x))) - (layout-inherits layout)))) + (list* (the (unsigned-byte 16) (wrapper-flags wrapper)) + (wrapper-depthoid wrapper) + (map 'list #'sb-kernel::wrapper-classoid-name + (wrapper-inherits wrapper)))) (dolist (dsd (dd-slots dd) (format output ")~%")) (format output " (~d ~S ~S)~%" (sb-kernel::dsd-bits dsd) diff -Nru sbcl-2.1.1/src/code/late-format.lisp sbcl-2.1.11/src/code/late-format.lisp --- sbcl-2.1.1/src/code/late-format.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/late-format.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,1583 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-FORMAT") - -;;;; TOKENIZE-CONTROL-STRING - -;;; The case for caching is to speed up out-of-line calls that use a fixed -;;; control string in a loop, not to avoid re-tokenizing all strings that -;;; happen to be STRING= to that string. -;;; (Might we want to bypass the cache when compile-time tokenizing?) -#+sb-xc-host -(defun tokenize-control-string (string) - (combine-directives - (%tokenize-control-string string 0 (length string) nil) - t)) -#-sb-xc-host -(defun-cached (tokenize-control-string - :memoizer memoize - :hash-bits 7 - :hash-function #'pointer-hash) - ((string eq)) - (declare (simple-string string)) - (macrolet ((compute-it () - `(combine-directives - (%tokenize-control-string string 0 (length string) nil) - t))) - (if (logtest (get-header-data string) - ;; shareable = readonly - (logior sb-vm:+vector-shareable+ - sb-vm:+vector-shareable-nonstd+)) - (memoize (compute-it)) - (compute-it)))) - -;;; If at some point I can figure out how to *CORRECTLY* utilize -;;; non-simple strings, then the INDEX and END will bound the parse. -;;; [Tokenization is the easy part, it's the substring extraction -;;; and processing, and error reporting, that become very complicated] -(defun %tokenize-control-string (string index end symbols) - (declare (simple-string string)) - (let ((result nil) - ;; FIXME: consider rewriting this 22.3.5.2-related processing - ;; using specials to maintain state and doing the logic inside - ;; the directive expanders themselves. - (block) - (pprint) - (semicolon) - (justification-semicolon)) - (loop - (let ((next-directive (or (position #\~ string :start index :end end) end))) - (when (> next-directive index) - (push (possibly-base-stringize (subseq string index next-directive)) - result)) - (when (= next-directive end) - (return)) - (let* ((directive (parse-directive string next-directive symbols)) - (char (directive-character directive))) - ;; this processing is required by CLHS 22.3.5.2 - (cond - ((char= char #\<) (push directive block)) - ((and block (char= char #\;) (directive-colonp directive)) - (setf semicolon directive)) - ((char= char #\>) - (unless block - (format-error-at string next-directive - "~~> without a matching ~~<")) - (cond - ((directive-colonp directive) - (unless pprint - (setf pprint (car block))) - (setf semicolon nil)) - (semicolon - (unless justification-semicolon - (setf justification-semicolon semicolon)))) - (pop block)) - ;; block cases are handled by the #\< expander/interpreter - ((not block) - (case char - ((#\W #\I #\_) (unless pprint (setf pprint directive))) - (#\T (when (and (directive-colonp directive) - (not pprint)) - (setf pprint directive)))))) - (push directive result) - (when (char= (directive-character directive) #\/) - (pop symbols)) - (setf index (directive-end directive))))) - (when (and pprint justification-semicolon) - (let ((pprint-offset (1- (directive-end pprint))) - (justification-offset - (1- (directive-end justification-semicolon)))) - (format-error-at* - string (min pprint-offset justification-offset) - "Misuse of justification and pprint directives" '() - :second-relative (- (max pprint-offset justification-offset) - (min pprint-offset justification-offset) - 1) - :references '((:ansi-cl :section (22 3 5 2)))))) - (nreverse result))) - -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) -(defun parse-directive (string start symbols) - (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) - (end (length string))) - (flet ((get-char () - (if (= posn end) - (format-error-at string start - "String ended before directive was found") - (schar string posn))) - (check-ordering () - (when (or colonp atsignp) - (format-error-at* - string posn - "Parameters found after #\\: or #\\@ modifier" '() - :references '((:ansi-cl :section (22 3))))))) - (loop - (let ((char (get-char))) - (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-)) - (check-ordering) - (multiple-value-bind (param new-posn) - (parse-integer string :start posn :junk-allowed t) - (push (cons posn param) params) - (setf posn new-posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return))))) - ((or (char= char #\v) - (char= char #\V)) - (check-ordering) - (push (cons posn :arg) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\#) - (check-ordering) - (push (cons posn :remaining) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((char= char #\') - (check-ordering) - (incf posn) - (push (cons posn (get-char)) params) - (incf posn) - (unless (char= (get-char) #\,) - (decf posn))) - ((char= char #\,) - (check-ordering) - (push (cons posn nil) params)) - ((char= char #\:) - (if colonp - (format-error-at* - string posn "Too many colons supplied" '() - :references '((:ansi-cl :section (22 3)))) - (setf colonp t))) - ((char= char #\@) - (if atsignp - (format-error-at* - string posn "Too many #\\@ characters supplied" '() - :references '((:ansi-cl :section (22 3)))) - (setf atsignp t))) - (t - (when (and (char= (schar string (1- posn)) #\,) - (or (< posn 2) - (char/= (schar string (- posn 2)) #\'))) - (check-ordering) - (push (cons (1- posn) nil) params)) - (return)))) - (incf posn)) - (let ((char (get-char))) - (when (char= char #\/) - (let ((closing-slash (position #\/ string :start (1+ posn)))) - (if closing-slash - (setf posn closing-slash) - (format-error-at string posn "No matching closing slash")))) - (make-format-directive - string start (1+ posn) - (nreverse params) colonp atsignp (char-upcase char) - (when (eql char #\/) (car symbols)))))))) - -;;; Make a few simplifications to the directive list in INPUT, -;;; including translation of ~% to literal newline. -;;; I think that this does not have implications on conditional newlines -;;; vis a vis "When a line break is inserted by any type of conditional -;;; newline, any blanks that immediately precede the conditional newline -;;; are omitted". i.e. one could argue that nonliteral blanks are not -;;; quite the same as literal blanks, i.e. not subject to removal, -;;; but I don't think that's true, and in fact that is the source of -;;; an extremely subtle bug that writing the #\space character as a -;;; physical space character followed by a conditional newline is, -;;; if taken literally, supposed to remove the desired output. -(defun combine-directives (input literalize-tilde) - (let (output) - (labels ((emit-string (string) - (if (stringp (car output)) - (rplaca output (concat (car output) string)) - (push string output))) - (emit-placeholder-p () - ;; Return T if an otherwise empty string inside ~{ ... ~} must be - ;; kept in order to avoid turning "~{~0|~}" (etc) into "~{~}". - ;; The latter control string means something completely different. - (and (format-directive-p (car output)) - (eql #\{ (directive-character (car output))))) - (emit-directive (directive) - ;; If the head of output is the empty string and DIRECTIVE is - ;; NOT a closing curly brace, we can reuse the first cons cell. - (if (and (typep (car output) '(string 0)) - (char/= (directive-character directive) #\})) - (rplaca output directive) - (push directive output))) - (concat (first second) - ;; The result is a base-string iff both inputs are base-string. - ;; %TOKENIZE-CONTROL-STRING calls POSSIBLY-BASE-STRINGIZE - ;; on all pieces of the input. - ;; I suspect that this may be permissible for CONCATENATE generally - ;; when given 'STRING as its output type with base-string as inputs. - ;; But as with all things string, the spec is unclear as usual imho. - (cond ((and (typep first 'base-string) - (typep second 'base-string)) - (concatenate 'base-string first second)) - (t - (concatenate 'string first second))))) - (loop - (unless input (return (nreverse output))) - (let ((item (pop input))) - (etypecase item - (string - (aver (plusp (length item))) - (emit-string item)) - ;; - Handle tilde-newline immediately - ;; - Turn "~%" into literal newline (for parameter N <=127) - ;; - Unless x-compiling, turn "~|" into literal form-feed (ditto) - ;; - Optionally turn "~~" into literal tilde (ditto) - (format-directive - (let ((params (directive-params item)) - (colon (directive-colonp item)) - (atsign (directive-atsignp item)) - (char (directive-character item))) - (block nil - (case char - (#\Newline - ;; tilde newline wants no params, and not both colon+atsign - (when (and (not params) (not (and colon atsign))) - ;; atsign = preserve newline / colon = preserve whitespace - (let ((s (concat (if atsign - #.(make-string 1 :initial-element #\Newline) - "") - (if (and (not colon) (stringp (car input))) - (string-left-trim - ;; #\Tab is a nonstandard char - `(#-sb-xc-host ,(sb-xc:code-char tab-char-code) - #\space #\newline) - (pop input)) - "")))) - (when (or (plusp (length s)) (emit-placeholder-p)) - (emit-string s))) - (return))) - ;; TODO: #\& with a literal parameter of 0 is equivalent - ;; to the empty string. - ((#\% #\~ #-sb-xc-host #\|) ; #\Page is a nonstandard char - (let ((n (or (cdar params) 1))) - (when (and (not (or colon atsign)) - (or (null params) (singleton-p params)) - (typep n '(mod 128)) - ;; Don't insert literal tilde when parsing/ - ;; unparsing to create a FMT-CONTROL instance. - (or (not (eql char #\~)) literalize-tilde)) - (when (or (plusp n) (emit-placeholder-p)) - (let ((char (case char - (#\% #\Newline) - (#\| (sb-xc:code-char form-feed-char-code)) - (t char)))) - (emit-string (make-string n :initial-element char)))) - (return))))) - (emit-directive item)))))))))) - -;;;; FORMATTER stuff - -(sb-xc:defmacro formatter (control-string) - `#',(%formatter control-string)) - -(defun %formatter (control-string &optional (arg-count 0) (need-retval t) - &aux (lambda-name - (possibly-base-stringize - (concatenate 'string "fmt$" control-string)))) - ;; ARG-COUNT is supplied only when the use of this formatter is in a literal - ;; call to FORMAT, in which case we can possibly elide &optional parsing. - ;; But we can't in general, because FORMATTER may be called by users - ;; to obtain functions that may be invoked in random wrong ways. - ;; NEED-RETVAL signifies that the caller wants back the list of - ;; unconsumed arguments. This is the default assumption. - (block nil - (catch 'need-orig-args - (let* ((*simple-args* nil) - (*only-simple-args* t) - (control-string (coerce control-string 'simple-string)) - (guts (expand-control-string control-string)) ; can throw - (required nil) - (optional nil)) - (dolist (arg *simple-args*) - (cond ((plusp arg-count) - (push (car arg) required) - (decf arg-count)) - (t - (push `(,(car arg) - (args-exhausted ,control-string ,(cdr arg))) - optional)))) - (return `(named-lambda ,lambda-name - (stream ,@required - ,@(if optional '(&optional)) ,@optional - &rest args) - (declare (ignorable stream args)) - ,guts - ,(and need-retval 'args))))) - (let ((*orig-args-available* t) - (*only-simple-args* nil)) - `(named-lambda ,lambda-name (stream &rest orig-args) - (declare (ignorable stream)) - (let ((args orig-args)) - ,(expand-control-string control-string) - ,(and need-retval 'args)))))) - -(defun args-exhausted (control-string offset) - (format-error-at control-string offset "No more arguments")) - -(defvar *format-gensym-counter*) -(defun expand-control-string (string) - (let* ((string (etypecase string - (simple-string - string) - (string - (coerce string 'simple-string)))) - (*default-format-error-control-string* string) - (*format-gensym-counter* 0) - (directives (tokenize-control-string string))) - `(block nil - ,@(expand-directive-list directives)))) - -(defun expand-directive-list (directives) - (let ((results nil) - previous - (remaining-directives directives)) - (loop - (unless remaining-directives - (return)) - (multiple-value-bind (form new-directives) - (expand-directive (car remaining-directives) - (cdr remaining-directives)) - (flet ((merge-string (string) - (cond (previous - ;; It would be nice if (CONCATENTE 'STRING) - ;; could return the "smallest" string type - ;; able to hold the result. Or at least if we - ;; had a better interface than wrapping - ;; it with POSSIBLY-BASE-STRINGIZE since that - ;; conses two new strings usually. - (let ((concat - (possibly-base-stringize - (concatenate 'string - (string previous) - (string string))))) - (setf previous concat) - (setf (car results) - `(write-string ,concat stream)))) - (t - (setf previous string) - (push form results))))) - (cond ((not form)) - ((typep form '(cons (member write-string write-char) - (cons (or string character)))) - (merge-string (second form))) - ((typep form '(cons (eql terpri))) - (merge-string #\Newline)) - (t - (push form results) - (setf previous nil)))) - (setf remaining-directives new-directives))) - (nreverse results))) - -(defun expand-directive (directive more-directives) - (etypecase directive - (format-directive - (let ((expander - (aref *format-directive-expanders* (directive-code directive))) - (*default-format-error-offset* - (1- (directive-end directive)))) - (if (functionp expander) - (funcall expander directive more-directives) - (format-error "Unknown directive ~@[(character: ~A)~]" - (directive-char-name directive))))) - ((simple-string 1) - (values `(write-char ,(schar directive 0) stream) - more-directives)) - (simple-string - (values `(write-string ,directive stream) - more-directives)))) - -(sb-xc:defmacro expander-next-arg (string offset) - `(if args - (pop args) - (format-error-at ,string ,offset "No more arguments"))) - -(defun expand-next-arg (&optional offset) - (if (or *orig-args-available* (not *only-simple-args*)) - `(,*expander-next-arg-macro* - ,*default-format-error-control-string* - ,(or offset *default-format-error-offset*)) - (let ((symbol - (without-package-locks - (package-symbolicate - #.(find-package "SB-FORMAT") - "FORMAT-ARG" - (write-to-string (incf *format-gensym-counter*) - :pretty nil :base 10 :radix nil))))) - (push (cons symbol (or offset *default-format-error-offset*)) - *simple-args*) - symbol))) - -(defmacro expand-bind-defaults (specs params &body body) - (once-only ((params params)) - (if specs - (collect ((expander-bindings) (runtime-bindings)) - (dolist (spec specs) - (destructuring-bind (var default) spec - (let ((symbol (sb-xc:gensym "FVAR"))) - (expander-bindings - `(,var ',symbol)) - (runtime-bindings - `(list ',symbol - (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg `(or ,(expand-next-arg offset) ,,default)) - (:remaining - (setf *only-simple-args* nil) - '(length args)) - ((nil) ,default) - (t param)))))))) - `(let ,(expander-bindings) - `(let ,(list ,@(runtime-bindings)) - ,@(if ,params - (format-error-at - nil (caar ,params) - "Too many parameters, expected no more than ~W" - ,(length specs))) - ,,@body))) - `(progn - (when ,params - (format-error-at nil (caar ,params) - "Too many parameters, expected none")) - ,@body)))) - -;;;; format directive machinery - -(defmacro def-complex-format-directive (char lambda-list &body body) - (let ((defun-name (intern (format nil - "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" - char))) - (directive (sb-xc:gensym "DIRECTIVE")) - (directives (if lambda-list (car (last lambda-list)) (sb-xc:gensym "DIRECTIVES")))) - `(progn - (defun ,defun-name (,directive ,directives) - ,@(if lambda-list - `((let ,(mapcar (lambda (var) - `(,var - (,(symbolicate "DIRECTIVE-" var) ,directive))) - (butlast lambda-list)) - ,@body)) - `((declare (ignore ,directive ,directives)) - ,@body))) - (%set-format-directive-expander ,char #',defun-name)))) - -(defmacro def-format-directive (char lambda-list &body body) - (let ((directives (sb-xc:gensym "DIRECTIVES")) - (declarations nil) - (body-without-decls body)) - (loop - (let ((form (car body-without-decls))) - (unless (and (consp form) (eq (car form) 'declare)) - (return)) - (push (pop body-without-decls) declarations))) - (setf declarations (reverse declarations)) - `(def-complex-format-directive ,char (,@lambda-list ,directives) - ,@declarations - (values (progn ,@body-without-decls) - ,directives)))) - -(defun %set-format-directive-expander (char fn) - (let ((code (sb-xc:char-code (char-upcase char)))) - (setf (aref *format-directive-expanders* code) fn)) - char) - -(defun find-directive (directives kind stop-at-semi) - (if directives - (let ((next (car directives))) - (if (format-directive-p next) - (let ((char (directive-character next))) - (if (or (char= kind char) - (and stop-at-semi (char= char #\;))) - (car directives) - (find-directive - (cdr (flet ((after (char) - (member (find-directive (cdr directives) - char - nil) - directives))) - (case char - (#\( (after #\))) - (#\< (after #\>)) - (#\[ (after #\])) - (#\{ (after #\})) - (t directives)))) - kind stop-at-semi))) - (find-directive (cdr directives) kind stop-at-semi))))) - -;;;; format directives for simple output - -(def-format-directive #\A (colonp atsignp params) - (if params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp - ,mincol ,colinc ,minpad ,padchar)) - `(princ ,(if colonp - `(or ,(expand-next-arg) "()") - (expand-next-arg)) - stream))) - -(def-format-directive #\S (colonp atsignp params) - (cond (params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))) - (colonp - `(let ((arg ,(expand-next-arg))) - (if arg - (prin1 arg stream) - (princ "()" stream)))) - (t - `(prin1 ,(expand-next-arg) stream)))) - -(def-format-directive #\C (colonp atsignp params string end) - (expand-bind-defaults () params - (let ((n-arg (sb-xc:gensym "ARG"))) - `(let ((,n-arg ,(expand-next-arg))) - (unless (typep ,n-arg 'character) - (format-error-at ,string ,(1- end) - "~S is not of type CHARACTER." ,n-arg)) - ,(cond (colonp - `(format-print-named-character ,n-arg stream)) - (atsignp - `(prin1 ,n-arg stream)) - (t - `(write-char ,n-arg stream))))))) - -(def-format-directive #\W (colonp atsignp params) - (expand-bind-defaults () params - (if (or colonp atsignp) - `(let (,@(when colonp - '((*print-pretty* t))) - ,@(when atsignp - '((*print-level* nil) - (*print-length* nil)))) - (output-object ,(expand-next-arg) stream)) - `(output-object ,(expand-next-arg) stream)))) - -;;;; format directives for integer output - -(defun expand-format-integer (base colonp atsignp params) - (if (or colonp atsignp params) - (expand-bind-defaults - ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) - params - `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp - ,base ,mincol ,padchar ,commachar - ,commainterval)) - `(let ((*print-base* ,base) - (*print-radix* nil)) - (princ ,(expand-next-arg) stream)))) - -(def-format-directive #\D (colonp atsignp params) - (expand-format-integer 10 colonp atsignp params)) - -(def-format-directive #\B (colonp atsignp params) - (expand-format-integer 2 colonp atsignp params)) - -(def-format-directive #\O (colonp atsignp params) - (expand-format-integer 8 colonp atsignp params)) - -(def-format-directive #\X (colonp atsignp params) - (expand-format-integer 16 colonp atsignp params)) - -(def-format-directive #\R (colonp atsignp params string end) - (expand-bind-defaults - ((base nil) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - (let ((n-arg (sb-xc:gensym "ARG"))) - `(let ((,n-arg ,(expand-next-arg))) - (unless (or ,base - (integerp ,n-arg)) - (format-error-at ,string ,(1- end) "~S is not of type INTEGER." ,n-arg)) - (if ,base - (format-print-integer stream ,n-arg ,colonp ,atsignp - ,base ,mincol - ,padchar ,commachar ,commainterval) - ,(if atsignp - (if colonp - `(format-print-old-roman stream ,n-arg) - `(format-print-roman stream ,n-arg)) - (if colonp - `(format-print-ordinal stream ,n-arg) - `(format-print-cardinal stream ,n-arg)))))))) - -;;;; format directive for pluralization - -(def-format-directive #\P (colonp atsignp params end) - (expand-bind-defaults () params - (let ((arg (cond - ((not colonp) - (expand-next-arg)) - (*orig-args-available* - `(if (eq orig-args args) - (format-error-at - ,*default-format-error-control-string* ,(1- end) - "No previous argument") - (do ((arg-ptr orig-args (cdr arg-ptr))) - ((eq (cdr arg-ptr) args) - (car arg-ptr))))) - (*only-simple-args* - (unless *simple-args* - (format-error "No previous argument")) - (caar *simple-args*)) - (t - (/show0 "THROWing NEED-ORIG-ARGS from tilde-P") - (throw 'need-orig-args nil))))) - (if atsignp - `(write-string (if (eql ,arg 1) "y" "ies") stream) - `(unless (eql ,arg 1) (write-char #\s stream)))))) - -;;;; format directives for floating point output - -(def-format-directive #\F (colonp atsignp params) - (check-modifier "colon" colonp) - (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params - `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) - -(def-format-directive #\E (colonp atsignp params) - (check-modifier "colon" colonp) - (expand-bind-defaults - ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) - params - `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark - ,atsignp))) - -(def-format-directive #\G (colonp atsignp params) - (check-modifier "colon" colonp) - (expand-bind-defaults - ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) - params - `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) - -(def-format-directive #\$ (colonp atsignp params) - (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params - `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp - ,atsignp))) - -;;;; format directives for line/page breaks etc. - -(def-format-directive #\% (colonp atsignp params) - (check-modifier "colon" colonp) - (check-modifier "at-sign" atsignp) - (cond ((not params) - '(terpri stream)) - ((typep params '(cons (cons * (mod 65536)) null)) - `(write-string ,(make-string (cdar params) :initial-element #\Newline) stream)) - (t - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (terpri stream)))))) - -(def-format-directive #\& (colonp atsignp params) - (check-modifier "colon" colonp) - (check-modifier "at-sign" atsignp) - (if params - (expand-bind-defaults ((count 1)) params - `(progn - (when (plusp ,count) - (fresh-line stream) - (dotimes (i (1- ,count)) - (terpri stream))))) - '(fresh-line stream))) - -(def-format-directive #\| (colonp atsignp params) - (check-modifier "colon" colonp) - (check-modifier "at-sign" atsignp) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char (code-char form-feed-char-code) stream))) - '(write-char (code-char form-feed-char-code) stream))) - -(def-format-directive #\~ (colonp atsignp params) - (check-modifier "colon" colonp) - (check-modifier "at-sign" atsignp) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\~ stream))) - '(write-char #\~ stream))) - -;;; We'll only get here when the directive usage is illegal. -;;; COMBINE-DIRECTIVES would have handled a legal directive. -(def-complex-format-directive #\newline (colonp atsignp params directives) - (check-modifier '("colon" "at-sign") (and colonp atsignp)) - (values (expand-bind-defaults () params) - (bug "Unreachable ~S" directives))) - -;;;; format directives for tabs and simple pretty printing - -(def-format-directive #\T (colonp atsignp params) - (if colonp - (expand-bind-defaults ((n 1) (m 1)) params - `(pprint-tab ,(if atsignp :section-relative :section) - ,n ,m stream)) - (if atsignp - (expand-bind-defaults ((colrel 1) (colinc 1)) params - `(format-relative-tab stream ,colrel ,colinc)) - (expand-bind-defaults ((colnum 1) (colinc 1)) params - `(format-absolute-tab stream ,colnum ,colinc))))) - -(def-format-directive #\_ (colonp atsignp params) - (expand-bind-defaults () params - `(pprint-newline ,(if colonp - (if atsignp - :mandatory - :fill) - (if atsignp - :miser - :linear)) - stream))) - -(def-format-directive #\I (colonp atsignp params) - (check-modifier "at-sign" atsignp) - (expand-bind-defaults ((n 0)) params - `(pprint-indent ,(if colonp :current :block) ,n stream))) - -;;;; format directive for ~* - -(def-format-directive #\* (colonp atsignp params end) - (check-modifier '("colon" "at-sign") (and colonp atsignp)) - (flet ((make-lose (index) - `(format-error-at - ,*default-format-error-control-string* ,(1- end) - "Index ~W is out of bounds. It should have been between ~ - 0 and ~W." - ,index (length orig-args)))) - (if atsignp - (expand-bind-defaults ((posn 0)) params - (unless *orig-args-available* - (/show0 "THROWing NEED-ORIG-ARGS from tilde-@*") - (throw 'need-orig-args nil)) - `(if (<= 0 ,posn (length orig-args)) - (setf args (nthcdr ,posn orig-args)) - ,(make-lose posn))) - (if colonp - (expand-bind-defaults ((n 1)) params - (unless *orig-args-available* - (/show0 "THROWing NEED-ORIG-ARGS from tilde-:*") - (throw 'need-orig-args nil)) - `(do ((cur-posn 0 (1+ cur-posn)) - (arg-ptr orig-args (cdr arg-ptr))) - ((eq arg-ptr args) - (let ((new-posn (- cur-posn ,n))) - (if (<= 0 new-posn (length orig-args)) - (setf args (nthcdr new-posn orig-args)) - ,(make-lose 'new-posn)))))) - (if params - (expand-bind-defaults ((n 1)) params - (setf *only-simple-args* nil) - `(dotimes (i ,n) - ,(expand-next-arg))) - (expand-next-arg)))))) - -;;;; format directive for indirection - -(def-format-directive #\? (colonp atsignp params string end) - (check-modifier "colon" colonp) - (expand-bind-defaults () params - `(handler-bind - ((format-error - (lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :args (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) - ,(if atsignp - (if *orig-args-available* - `(setf args (%format stream ,(expand-next-arg) orig-args args)) - (throw 'need-orig-args nil)) - `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) - -;;;; format directives for capitalization - -(def-complex-format-directive #\( (colonp atsignp params directives) - (let* ((close (or (find-directive directives #\) nil) - (format-error "No corresponding close parenthesis"))) - (posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives))) - (values - (expand-bind-defaults () params - `(let ((stream (make-case-frob-stream stream - ,(if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - ,@(expand-directive-list before))) - after))) - -(def-complex-format-directive #\) () - (format-error "No corresponding open parenthesis")) - -;;;; format directives and support functions for conditionalization - -(def-complex-format-directive #\[ (colonp atsignp params directives) - (check-modifier '("colon" "at-sign") (and colonp atsignp)) - (multiple-value-bind (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (values - (cond - (atsignp - (when (cdr sublists) - (format-error "Can only specify one section")) - (expand-bind-defaults () params - (expand-maybe-conditional (car sublists)))) - (colonp - (unless (= (length sublists) 2) - (format-error "Must specify exactly two sections")) - (expand-bind-defaults () params - (apply #'expand-true-false-conditional sublists))) - (t - (expand-bind-defaults ((index nil)) params - (setf *only-simple-args* nil) - (let ((clauses nil) - (case-sym (gensym)) - (case `(or ,index ,(expand-next-arg)))) - (when last-semi-with-colon-p - (push `(t ,@(expand-directive-list (pop sublists))) - clauses)) - (let ((count (length sublists))) - (dolist (sublist sublists) - (push `(,(decf count) - ,@(expand-directive-list sublist)) - clauses))) - `(let ((,case-sym ,case)) - (unless (integerp ,case-sym) - (format-error-at - ,*default-format-error-control-string* - ,*default-format-error-offset* - "The argument to ~~[ is not an integer: ~A" ,case-sym)) - (case ,case-sym ,@clauses)))))) - remaining))) - -(defun parse-conditional-directive (directives) - (let ((sublists nil) - (last-semi-with-colon-p nil) - (remaining directives)) - (loop - (let* ((close-or-semi (or (find-directive remaining #\] t) - (format-error "No corresponding close bracket"))) - (posn (position close-or-semi remaining))) - (push (subseq remaining 0 posn) sublists) - (setf remaining (nthcdr (1+ posn) remaining)) - (when (char= (directive-character close-or-semi) #\]) - (return)) - (setf last-semi-with-colon-p - (directive-colonp close-or-semi)))) - (values sublists last-semi-with-colon-p remaining))) - -(defun expand-maybe-conditional (sublist) - (flet ((hairy () - `(let ((prev-args args) - (arg ,(expand-next-arg))) - (when arg - (setf args prev-args) - ,@(expand-directive-list sublist))))) - (if *only-simple-args* - (multiple-value-bind (guts new-args) - (let ((*simple-args* *simple-args*)) - (values (expand-directive-list sublist) - *simple-args*)) - (cond ((and new-args (eq *simple-args* (cdr new-args))) - (setf *simple-args* new-args) - `(when ,(caar new-args) - ,@guts)) - (t - (setf *only-simple-args* nil) - (hairy)))) - (hairy)))) - -(defun expand-true-false-conditional (true false) - (let ((arg (expand-next-arg))) - (flet ((hairy () - `(if ,arg - (progn - ,@(expand-directive-list true)) - (progn - ,@(expand-directive-list false))))) - (if *only-simple-args* - (multiple-value-bind (true-guts true-args true-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list true) - *simple-args* - *only-simple-args*)) - (multiple-value-bind (false-guts false-args false-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list false) - *simple-args* - *only-simple-args*)) - (if (= (length true-args) (length false-args)) - `(if ,arg - (progn - ,@true-guts) - ,(do ((false false-args (cdr false)) - (true true-args (cdr true)) - (bindings nil (cons `(,(caar false) ,(caar true)) - bindings))) - ((eq true *simple-args*) - (setf *simple-args* true-args) - (setf *only-simple-args* - (and true-simple false-simple)) - (if bindings - `(let ,bindings - ,@false-guts) - `(progn - ,@false-guts))))) - (progn - (setf *only-simple-args* nil) - (hairy))))) - (hairy))))) - -(def-complex-format-directive #\; () - (format-error - "~~; directive not contained within either ~~[...~~] or ~~<...~~>")) - -(def-complex-format-directive #\] () - (format-error "No corresponding open bracket")) - -;;;; format directive for up-and-out - -(def-format-directive #\^ (colonp atsignp params) - (check-modifier "at-sign" atsignp) - (when (and colonp (not *up-up-and-out-allowed*)) - (format-error "Attempt to use ~~:^ outside a ~~:{...~~} construct")) - `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params - `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3)) - (,arg2 (eql ,arg1 ,arg2)) - (,arg1 (eql ,arg1 0)) - (t ,(if colonp - '(null outside-args) - (progn - (setf *only-simple-args* nil) - '(null args)))))) - ,(if colonp - '(return-from outside-loop nil) - '(return)))) - -;;;; format directives for iteration - -(def-complex-format-directive #\{ (colonp atsignp params string end directives) - (let* ((close (or (find-directive directives #\} nil) - (format-error "No corresponding close brace"))) - (closed-with-colon (directive-colonp close)) - (posn (position close directives))) - (labels - ((compute-insides () - (if (zerop posn) - (if *orig-args-available* - `((handler-bind - ((format-error - (lambda (condition) - (format-error-at* - ,string ,(1- end) - "~A~%while processing indirect format string:" - (list condition) - :print-banner nil)))) - (setf args - (%format stream inside-string orig-args args)))) - (throw 'need-orig-args nil)) - (let ((*up-up-and-out-allowed* colonp)) - (expand-directive-list (subseq directives 0 posn))))) - (compute-loop (count) - (when atsignp - (setf *only-simple-args* nil)) - `(loop - ,@(unless closed-with-colon - '((when (null args) - (return)))) - ,@(when count - `((when (and ,count (minusp (decf ,count))) - (return)))) - ,@(if colonp - (let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - `((let* ((orig-args ,(expand-next-arg)) - (outside-args args) - (args orig-args)) - (declare (ignorable orig-args outside-args args)) - (block nil - ,@(compute-insides))))) - (compute-insides)) - ,@(when closed-with-colon - '((when (null args) - (return)))))) - (compute-block (count) - (if colonp - `(block outside-loop - ,(compute-loop count)) - (compute-loop count))) - (compute-bindings (count) - (if atsignp - (compute-block count) - `(let* ((orig-args ,(expand-next-arg)) - (args orig-args)) - (declare (ignorable orig-args args)) - ,(let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - (compute-block count)))))) - (values (if params - (expand-bind-defaults ((count nil)) params - (if (zerop posn) - `(let ((inside-string ,(expand-next-arg))) - ,(compute-bindings count)) - (compute-bindings count))) - (if (zerop posn) - `(let ((inside-string ,(expand-next-arg))) - ,(compute-bindings nil)) - (compute-bindings nil))) - (nthcdr (1+ posn) directives))))) - -(def-complex-format-directive #\} () - (format-error "No corresponding open brace")) - -;;;; format directives and support functions for justification - -(defconstant-eqx !illegal-inside-justification - '#.(mapcar (lambda (x) (directive-bits (parse-directive x 0 nil))) - '("~:>" "~:@>" - "~:T" "~:@T")) - #'equal) - -;;; Reject ~W, ~_, ~I and certain other specific values of modifier+character. -(defun illegal-inside-justification-p (directive) - (and (format-directive-p directive) - (if (or (member (directive-bits directive) !illegal-inside-justification) - (member (directive-character directive) '(#\W #\I #\_))) - t - nil))) - -(def-complex-format-directive #\< (colonp atsignp params string end directives) - (multiple-value-bind (segments first-semi close remaining) - (parse-format-justification directives) - (values - (if (directive-colonp close) ; logical block vs. justification - (multiple-value-bind (prefix per-line-p insides suffix) - (parse-format-logical-block segments colonp first-semi - close params string end) - (expand-format-logical-block prefix per-line-p insides - suffix atsignp)) - (let ((count (reduce #'+ (mapcar (lambda (x) - (count-if #'illegal-inside-justification-p x)) - segments)))) - (when (> count 0) - ;; ANSI specifies that "an error is signalled" in this - ;; situation. - (format-error* - "~D illegal directive~:P found inside justification block" - (list count) - :references '((:ansi-cl :section (22 3 5 2))))) - ;; ANSI does not explicitly say that an error should be - ;; signalled, but the @ modifier is not explicitly allowed - ;; for ~> either. - (when (directive-atsignp close) - (format-error-at* - nil (1- (directive-end close)) - "@ modifier not allowed in close directive of ~ - justification block (i.e. ~~<...~~@>." - '() - :references '((:ansi-cl :section (22 3 6 2))))) - (expand-format-justification segments colonp atsignp - first-semi params))) - remaining))) - -(def-complex-format-directive #\> () - (format-error "No corresponding open bracket")) - -(defun parse-format-logical-block - (segments colonp first-semi close params string end) - (when params - (format-error-at nil (caar params) - "No parameters can be supplied with ~~<...~~:>.")) - (multiple-value-bind (prefix insides suffix) - (multiple-value-bind (prefix-default suffix-default) - (if colonp (values "(" ")") (values "" "")) - (flet ((extract-string (list prefix-p) - (let ((directive (find-if #'format-directive-p list))) - (if directive - (format-error-at* - nil (1- (directive-end directive)) - "Cannot include format directives inside the ~ - ~:[suffix~;prefix~] segment of ~~<...~~:>" - (list prefix-p) - :references '((:ansi-cl :section (22 3 5 2)))) - (apply #'concatenate 'string list))))) - (case (length segments) - (0 (values prefix-default nil suffix-default)) - (1 (values prefix-default (car segments) suffix-default)) - (2 (values (extract-string (car segments) t) - (cadr segments) suffix-default)) - (3 (values (extract-string (car segments) t) - (cadr segments) - (extract-string (caddr segments) nil))) - (t - (format-error "Too many segments for ~~<...~~:>"))))) - (when (directive-atsignp close) - (setf insides - (add-fill-style-newlines insides - string - (if first-semi - (directive-end first-semi) - end)))) - (values prefix - (and first-semi (directive-atsignp first-semi)) - insides - suffix))) - -(defun add-fill-style-newlines (list string offset &optional last-directive) - (cond - (list - (let ((directive (car list))) - (cond - ((simple-string-p directive) - (let* ((non-space (position #\Space directive :test #'char/=)) - (newlinep (and last-directive - (char= (directive-character last-directive) - #\Newline)))) - (cond - ((and newlinep non-space) - (nconc - (list (subseq directive 0 non-space)) - (add-fill-style-newlines-aux - (subseq directive non-space) string (+ offset non-space)) - (add-fill-style-newlines - (cdr list) string (+ offset (length directive))))) - (newlinep - (cons directive - (add-fill-style-newlines - (cdr list) string (+ offset (length directive))))) - (t - (nconc (add-fill-style-newlines-aux directive string offset) - (add-fill-style-newlines - (cdr list) string (+ offset (length directive)))))))) - (t - (cons directive - (add-fill-style-newlines - (cdr list) string - (directive-end directive) directive)))))) - (t nil))) - -(defun add-fill-style-newlines-aux (literal string offset) - (let ((end (length literal)) - (posn 0)) - (collect ((results)) - (loop - (let ((blank (position #\space literal :start posn))) - (when (null blank) - (results (subseq literal posn)) - (return)) - (let ((non-blank (or (position #\space literal :start blank - :test #'char/=) - end))) - (results (subseq literal posn non-blank)) - (results (make-format-directive - string (+ offset non-blank) (+ offset non-blank) - nil t nil #\_ nil)) ; params,colon,atsign,char,symbol - (setf posn non-blank)) - (when (= posn end) - (return)))) - (results)))) - -(defun parse-format-justification (directives) - (let ((first-semi nil) - (close nil) - (remaining directives)) - (collect ((segments)) - (loop - (let ((close-or-semi (or (find-directive remaining #\> t) - (format-error "No corresponding close bracket")))) - (let ((posn (position close-or-semi remaining))) - (segments (subseq remaining 0 posn)) - (setf remaining (nthcdr (1+ posn) remaining))) - (when (char= (directive-character close-or-semi) #\>) - (setf close close-or-semi) - (return)) - (unless first-semi - (setf first-semi close-or-semi)))) - (values (segments) first-semi close remaining)))) - -(sb-xc:defmacro expander-pprint-next-arg (string offset) - `(progn - (when (null args) - (format-error-at ,string ,offset "No more arguments")) - (pprint-pop) - (pop args))) - -(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) - `(let ((arg ,(if atsignp 'args (expand-next-arg)))) - ,@(when atsignp - (setf *only-simple-args* nil) - '((setf args nil))) - (pprint-logical-block - (stream arg - ,(if per-line-p :per-line-prefix :prefix) ,prefix - :suffix ,suffix) - (let ((args arg) - ,@(unless atsignp - `((orig-args arg)))) - (declare (ignorable args ,@(unless atsignp '(orig-args)))) - (block nil - ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) - (*only-simple-args* nil) - (*orig-args-available* - (if atsignp *orig-args-available* t))) - (expand-directive-list insides))))))) - -(defun expand-format-justification (segments colonp atsignp first-semi params) - (let ((newline-segment-p - (and first-semi - (directive-colonp first-semi)))) - (expand-bind-defaults - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - params - `(let ((segments nil) - ,@(when newline-segment-p - '((newline-segment nil) - (extra-space 0) - (line-len 72)))) - (block nil - ,@(when newline-segment-p - `((setf newline-segment - (%with-output-to-string (stream) - ,@(expand-directive-list (pop segments)))) - ,(expand-bind-defaults - ((extra 0) - (line-len '(or (sb-impl::line-length stream) 72))) - (directive-params first-semi) - `(setf extra-space ,extra line-len ,line-len)))) - ,@(mapcar (lambda (segment) - `(push (%with-output-to-string (stream) - ,@(expand-directive-list segment)) - segments)) - segments)) - (format-justification stream - ,@(if newline-segment-p - '(newline-segment extra-space line-len) - '(nil 0 0)) - segments ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))))) - -;;;; format directive and support function for user-defined method - -(def-format-directive #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-fun-name string start end))) - (collect ((param-names) (bindings)) - (dolist (param-and-offset params) - (let ((param (cdr param-and-offset))) - (let ((param-name (sb-xc:gensym "PARAM"))) - (param-names param-name) - (bindings `(,param-name - ,(case param - (:arg (expand-next-arg)) - (:remaining '(length args)) - (t param))))))) - `(let ,(bindings) - (,symbol stream ,(expand-next-arg) ,colonp ,atsignp - ,@(param-names)))))) - -(defun extract-user-fun-name (string start end) - ;; Searching backwards avoids finding the wrong slash in a funky string - ;; such as "~'/,'//fun/" which passes #\/ twice to FUN as parameters. - (let* ((slash (or (position #\/ string :start start :end (1- end) - :from-end t) - (format-error "Malformed ~~/ directive"))) - (name (nstring-upcase (subseq string (1+ slash) (1- end)))) - (first-colon (position #\: name)) - (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) - (symbol - (cond ((and second-colon (= second-colon (1+ first-colon))) - (subseq name (1+ second-colon))) - (first-colon - (subseq name (1+ first-colon))) - (t name))) - (package - (if (not first-colon) - #.(find-package "COMMON-LISP-USER") - (let ((package-name (subseq name 0 first-colon))) - (or (find-package package-name) - ;; FIXME: should be PACKAGE-ERROR? Could we just - ;; use FIND-UNDELETED-PACKAGE-OR-LOSE? - (format-error "No package named ~S" package-name)))))) - (intern symbol package))) - -(defun extract-user-fun-directives (string) - (let* ((tokens (handler-case - (combine-directives - (%tokenize-control-string string 0 (length string) nil) - nil) - (error (e) - (declare (ignore e)) - (return-from extract-user-fun-directives (values nil nil))))) - (max-len (loop for token in tokens - sum (if (format-directive-p token) - (- (directive-end token) (directive-start token)) - (length token)))) - (new-string - (make-array max-len :element-type 'character :fill-pointer 0)) - (symbols)) - (dolist (token tokens) - (cond ((stringp token) - (aver (not (find #\~ token))) - (let ((new-start (fill-pointer new-string))) - (incf (fill-pointer new-string) (length token)) - (replace new-string token :start1 new-start))) - (t - (let* ((start (directive-start token)) - (end (directive-end token)) - (len (- end start)) - (new-start (fill-pointer new-string))) - (cond ((eql (directive-character token) #\/) - (push (handler-case (extract-user-fun-name string start end) - (error (e) - (declare (ignore e)) - (return-from extract-user-fun-directives - (values nil nil)))) - symbols) - ;; Don't copy past the first slash. Scan backwards for it - ;; exactly as is done in EXTRACT-USER-FUN-NAME above. - ;; This error can't really happen (as we've already produced - ;; a valid tokenization), but the error check avoids - ;; a warning about adding 1 to NIL. - (setq end (1+ (or (position #\/ string :start start :end (1- end) - :from-end t) - (error "Malformed ~~/ directive")))) - ;; compute new length to copy, +1 is for trailing slash - (incf (fill-pointer new-string) (1+ (- end start))) - (setf (char new-string (1- (fill-pointer new-string))) #\/)) - (t - (incf (fill-pointer new-string) len))) - (replace new-string string :start1 new-start - :start2 start :end2 end))))) - (values (nreverse symbols) - (possibly-base-stringize new-string)))) - -(push '("SB-FORMAT" tokens) *!removable-symbols*) -(sb-xc:defmacro tokens (string) - (declare (string string)) - (multiple-value-bind (symbols new-string) (extract-user-fun-directives string) - (if symbols - (make-fmt-control-proxy new-string symbols) - (possibly-base-stringize new-string)))) - -;;; compile-time checking for argument mismatch. This code is -;;; inspired by that of Gerd Moellmann, and comes decorated with -;;; FIXMEs: -(defun %compiler-walk-format-string (string args) - (let* ((string (coerce string 'simple-string)) - (*default-format-error-control-string* string)) - (macrolet ((incf-both (&optional (increment 1)) - `(progn - (incf min ,increment) - (incf max ,increment))) - (walk-complex-directive (function) - `(multiple-value-bind (min-inc max-inc remaining) - (,function directive directives args) - (incf min min-inc) - (incf max max-inc) - (setq directives remaining)))) - ;; FIXME: these functions take a list of arguments as well as - ;; the directive stream. This is to enable possibly some - ;; limited type checking on FORMAT's arguments, as well as - ;; simple argument count mismatch checking: when the minimum and - ;; maximum argument counts are the same at a given point, we - ;; know which argument is going to be used for a given - ;; directive, and some (annotated below) require arguments of - ;; particular types. - (labels - ((walk-justification (justification directives args) - (declare (ignore args)) - (let ((*default-format-error-offset* - (1- (directive-end justification)))) - (multiple-value-bind (segments first-semi close remaining) - (parse-format-justification directives) - (declare (ignore segments first-semi)) - (cond - ((not (directive-colonp close)) - (values 0 0 directives)) - ((directive-atsignp justification) - (values 0 call-arguments-limit directives)) - ;; FIXME: here we could assert that the - ;; corresponding argument was a list. - (t (values 1 1 remaining)))))) - (walk-conditional (conditional directives args) - (let ((*default-format-error-offset* - (1- (directive-end conditional)))) - (multiple-value-bind (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (declare (ignore last-semi-with-colon-p)) - (let ((sub-max - (loop for s in sublists - maximize (nth-value - 1 (walk-directive-list s args))))) - (cond - ((directive-atsignp conditional) - (values 1 (max 1 sub-max) remaining)) - ((loop for p in (directive-params conditional) - thereis (or (integerp (cdr p)) - (memq (cdr p) '(:remaining :arg)))) - (values 0 sub-max remaining)) - ;; FIXME: if not COLONP, then the next argument - ;; must be a number. - (t (values 1 (1+ sub-max) remaining))))))) - (walk-iteration (iteration directives args) - (declare (ignore args)) - (let ((*default-format-error-offset* - (1- (directive-end iteration)))) - (let* ((close (find-directive directives #\} nil)) - (posn (or (position close directives) - (format-error "No corresponding close brace"))) - (remaining (nthcdr (1+ posn) directives))) - ;; FIXME: if POSN is zero, the next argument must be - ;; a format control (either a function or a string). - (if (directive-atsignp iteration) - (values (if (zerop posn) 1 0) - call-arguments-limit - remaining) - ;; FIXME: the argument corresponding to this - ;; directive must be a list. - (let ((nreq (if (zerop posn) 2 1))) - (values nreq nreq remaining)))))) - (walk-directive-list (directives args) - (let ((min 0) (max 0)) - (loop - (let ((directive (pop directives))) - (when (null directive) - (return (values min (min max call-arguments-limit)))) - (when (format-directive-p directive) - (incf-both (count :arg (directive-params directive) - :key #'cdr)) - (let ((c (directive-character directive))) - (cond - ((find c "ABCDEFGORSWX$/") - (incf-both)) - ((char= c #\P) - (unless (directive-colonp directive) - (incf-both))) - ((or (find c "IT%&|_();>~") (char= c #\Newline))) - ;; FIXME: check correspondence of ~( and ~) - ((char= c #\<) - (walk-complex-directive walk-justification)) - ((char= c #\[) - (walk-complex-directive walk-conditional)) - ((char= c #\{) - (walk-complex-directive walk-iteration)) - ((char= c #\?) - ;; FIXME: the argument corresponding to this - ;; directive must be a format control. - (cond - ((directive-atsignp directive) - (incf min) - (setq max call-arguments-limit)) - (t (incf-both 2)))) - (t (throw 'give-up-format-string-walk nil)))))))))) - (catch 'give-up-format-string-walk - (let ((directives (tokenize-control-string string))) - (walk-directive-list directives args))))))) - -;;; Optimize common case of constant keyword arguments -;;; to WRITE and WRITE-TO-STRING -(flet - ((expand (fn object keys) - (do (streamvar bind ignore) - ((or (atom keys) (atom (cdr keys))) - (if keys ; fail - (values nil t) - (values - (let* ((objvar (copy-symbol 'object)) - (bind `((,objvar ,object) ,@(nreverse bind))) - (ignore (when ignore `((declare (ignore ,@ignore)))))) - (case fn - (write - ;; When :STREAM was specified, this used to insert a call - ;; to (OUT-SYNONYM-OF STREAMVAR) which added junk to the - ;; expansion which was not likely to improve performance. - ;; The benefit of this transform is that it avoids runtime - ;; keyword parsing and binding of 16 specials vars, *not* - ;; that it can inline testing for T or NIL as the stream. - `(let ,bind ,@ignore - ,@(if streamvar - `((%write ,objvar ,streamvar)) - `((output-object ,objvar *standard-output*) - ,objvar)))) - (write-to-string - (if (cdr bind) - `(let ,bind ,@ignore (stringify-object ,objvar)) - `(stringify-object ,object))))) - nil))) - (let* ((key (pop keys)) - (value (pop keys)) - (variable - (cond ((getf '(:array *print-array* - :base *print-base* - :case *print-case* - :circle *print-circle* - :escape *print-escape* - :gensym *print-gensym* - :length *print-length* - :level *print-level* - :lines *print-lines* - :miser-width *print-miser-width* - :pprint-dispatch *print-pprint-dispatch* - :pretty *print-pretty* - :radix *print-radix* - :readably *print-readably* - :right-margin *print-right-margin* - :suppress-errors *suppress-print-errors*) - key)) - ((and (eq key :stream) (eq fn 'write)) - (or streamvar (setq streamvar (copy-symbol 'stream)))) - (t - (return (values nil t)))))) - (when (assoc variable bind) - ;; First key has precedence, but we still need to execute the - ;; argument, and in the right order. - (setf variable (gensym "IGNORE")) - (push variable ignore)) - (push (list variable value) bind))))) - - (sb-c:define-source-transform write (object &rest keys) - (expand 'write object keys)) - - (sb-c:define-source-transform write-to-string (object &rest keys) - (expand 'write-to-string object keys))) diff -Nru sbcl-2.1.1/src/code/late-globaldb.lisp sbcl-2.1.11/src/code/late-globaldb.lisp --- sbcl-2.1.1/src/code/late-globaldb.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/late-globaldb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,14 +9,27 @@ (in-package "SB-IMPL") -;; Call FUNCTION once for each Name in globaldb that has information associated -;; with it, passing the function the Name as its only argument. -;; ;; This is in its own file to avoid creating an early dependency on ;; target-package iterators. (macrolet ((def (&rest situations) `(eval-when ,situations + ;; Return all function names that are stored in SYMBOL's packe-info. + ;; As an example, (INFO-NAME-LIST 'SB-PCL::DIRECT-SUPERCLASSES) => + ;; ((SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::READER) + ;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES BOUNDP) + ;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::WRITER)) + (defun info-name-list (symbol) + (let ((packed-info (symbol-dbinfo symbol)) + (list)) + (when packed-info + (do-packed-info-aux-key (packed-info key-index) + (push (construct-globaldb-name (%info-ref packed-info key-index) symbol) + list)) + (nconc (and (plusp (packed-info-field packed-info 0 0)) (list symbol)) + (nreverse list))))) + ;; Call FUNCTION once for each Name in globaldb that has information associated + ;; with it, passing the function the Name as its only argument. (defun call-with-each-globaldb-name (fun-designator) (let ((function (cl:coerce fun-designator 'function))) (with-package-iterator (iter (list-all-packages) :internal :external) @@ -28,7 +41,7 @@ ;; always keep it since we can't know if it has been seen once. (when (or (not (sb-xc:symbol-package symbol)) (eq package (sb-xc:symbol-package symbol))) - (dolist (name (info-vector-name-list symbol)) + (dolist (name (info-name-list symbol)) (funcall function name)))))) ,@(unless (equal situations '(:compile-toplevel)) `((dovector (obj (car *fdefns*)) diff -Nru sbcl-2.1.1/src/code/late-type.lisp sbcl-2.1.11/src/code/late-type.lisp --- sbcl-2.1.1/src/code/late-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/late-type.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,4249 +0,0 @@ -;;;; This file contains the definition of non-CLASS types (e.g. -;;;; subtypes of interesting BUILT-IN-CLASSes) and the interfaces to -;;;; the type system. Common Lisp type specifiers are parsed into a -;;;; somewhat canonical internal type representation that supports -;;;; type union, intersection, etc. (Except that ALIEN types have -;;;; moved out..) - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-KERNEL") - -(/show0 "late-type.lisp 19") - -(!begin-collecting-cold-init-forms) - -;;; ### Remaining incorrectnesses: -;;; -;;; There are all sorts of nasty problems with open bounds on FLOAT -;;; types (and probably FLOAT types in general.) - -;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that -;;; compiler warnings can be emitted as appropriate. -(define-condition parse-unknown-type (condition) - ((specifier :reader parse-unknown-type-specifier :initarg :specifier)) - (:default-initargs - :specifier (missing-arg))) - -;;; This condition is signalled whenever we encounter a type (DEFTYPE, -;;; structure, condition, class) that has been marked as deprecated. -(define-condition parse-deprecated-type (condition) - ((specifier :reader parse-deprecated-type-specifier :initarg :specifier)) - (:default-initargs - :specifier (missing-arg))) - -;;; For-effect-only variant of CHECK-DEPRECATED-THING for -;;; type-specifiers that descends into compound type-specifiers. -(defun sb-impl::%check-deprecated-type (type-specifier) - (let ((seen '())) - ;; KLUDGE: we have to use SPECIFIER-TYPE to sanely traverse - ;; TYPE-SPECIFIER and detect references to deprecated types. But - ;; then we may have to drop its cache to get the - ;; PARSE-DEPRECATED-TYPE condition when TYPE-SPECIFIER is parsed - ;; again later. - ;; - ;; Proper fix would be a - ;; - ;; walk-type function type-specifier - ;; - ;; mechanism that could drive VALUES-SPECIFIER-TYPE but also - ;; things like this function. - (block nil - (handler-bind - ((parse-deprecated-type - (lambda (condition) - (let ((type-specifier (parse-deprecated-type-specifier condition))) - (aver (symbolp type-specifier)) - (unless (memq type-specifier seen) - (push type-specifier seen) - (check-deprecated-thing 'type type-specifier))))) - ((or error parse-unknown-type) - (lambda (condition) - (declare (ignore condition)) - (return)))) - (specifier-type type-specifier))))) - -(defun check-slot-type-specifier (specifier slot-name context) - ;; This signals an error for malformed type specifiers and - ;; deprecation warnings for deprecated types but does nothing for - ;; unknown types. - (with-current-source-form (specifier) - (handler-case - (and (specifier-type specifier) - (sb-impl::%check-deprecated-type specifier)) - (parse-unknown-type (c) - (when (typep specifier '(cons (eql quote))) - (signal c))) - (error (condition) - (destructuring-bind (operator . class-name) context - (sb-c:compiler-warn "Invalid :TYPE for slot ~S in ~S ~S: ~A." - slot-name operator class-name condition)))))) - -;;; These functions are used as method for types which need a complex -;;; subtypep method to handle some superclasses, but cover a subtree -;;; of the type graph (i.e. there is no simple way for any other type -;;; class to be a subtype.) There are always still complex ways, -;;; namely UNION and MEMBER types, so we must give TYPE1's method a -;;; chance to run, instead of immediately returning NIL, T. -(defun delegate-complex-subtypep-arg2 (type1 type2) - (let ((subtypep-arg1 - (type-class-complex-subtypep-arg1 (type-class type1)))) - (if subtypep-arg1 - (funcall subtypep-arg1 type1 type2) - (values nil t)))) -(defun delegate-complex-intersection2 (type1 type2) - (let ((method (type-class-complex-intersection2 (type-class type1)))) - (if (and method (not (eq method #'delegate-complex-intersection2))) - (funcall method type2 type1) - (hierarchical-intersection2 type1 type2)))) - -(defun map-type (function ctype) - (declare (type (or ctype null) ctype) - (dynamic-extent function)) - (named-let %map ((type ctype)) - (funcall function type) - (typecase type - (compound-type - (mapc #'%map (compound-type-types type))) - (negation-type (%map (negation-type-type type))) - (cons-type - (%map (cons-type-car-type type)) - (%map (cons-type-cdr-type type))) - (array-type - (%map (array-type-element-type type))) - (args-type - (mapc #'%map (args-type-required type)) - (mapc #'%map (args-type-optional type)) - (when (args-type-rest type) - (%map (args-type-rest type))) - (mapc (lambda (x) (%map (key-info-type x))) - (args-type-keywords type)) - (when (fun-type-p type) - (%map (fun-type-returns type)))))) - nil) - -(defun contains-unknown-type-p (ctype) - (map-type (lambda (type) - (when (unknown-type-p type) - (return-from contains-unknown-type-p t))) - ctype)) - -(defun contains-hairy-type-p (ctype) - (map-type (lambda (type) - (when (hairy-type-p type) - (return-from contains-hairy-type-p t))) - ctype)) - -(defun replace-hairy-type (type) - (if (contains-hairy-type-p type) - (typecase type - (hairy-type *universal-type*) - (intersection-type (%type-intersection - (mapcar #'replace-hairy-type (intersection-type-types type)))) - (union-type (%type-union - (mapcar #'replace-hairy-type (union-type-types type)))) - (negation-type - (let ((new (replace-hairy-type (negation-type-type type)))) - (if (eq new *universal-type*) - new - (type-negation new)))) - (t - *universal-type*)) - type)) - -;; Similar to (NOT CONTAINS-UNKNOWN-TYPE-P), but report that (SATISFIES F) -;; is not a testable type unless F is currently bound. -(defun testable-type-p (ctype) - (map-type - (lambda (ctype) - (typecase ctype - (unknown-type - (return-from testable-type-p nil)) ; must precede HAIRY because an unknown is HAIRY - (hairy-type - (let ((spec (hairy-type-specifier ctype))) - ;; Anything other than (SATISFIES ...) is testable - ;; because there's no reason to suppose that it isn't. - (unless (or (neq (car spec) 'satisfies) (fboundp (cadr spec))) - (return-from testable-type-p nil)))))) - ctype) - t) - -;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 -;;; method. INFO is a list of conses -;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). -(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) - ;; If TYPE2 might be concealing something related to our class - ;; hierarchy - (cond ((type-might-contain-other-types-p type2) - ;; too confusing, gotta punt - (values nil nil)) - ((fun-designator-type-p type1) - (values nil t)) - (t - ;; ordinary case expected by old CMU CL code, where the taxonomy - ;; of TYPE2's representation accurately reflects the taxonomy of - ;; the underlying set - (values - ;; FIXME: This old CMU CL code probably deserves a comment - ;; explaining to us mere mortals how it works... - (and (sb-xc:typep type2 'classoid) - (dolist (x info nil) - (let ((guard (cdr x))) - (when (or (not guard) - (csubtypep type1 (if (%instancep guard) - guard - (setf (cdr x) - (specifier-type guard))))) - (return - (or (eq type2 (car x)) - (let ((inherits (layout-inherits - (classoid-layout (car x))))) - (dotimes (i (length inherits) nil) - (when (eq type2 (layout-classoid (svref inherits i))) - (return t)))))))))) - t)))) - -;;; This function takes a list of specs, each of the form -;;; (SUPERCLASS-NAME &OPTIONAL GUARD). -;;; Consider one spec (with no guard): any instance of the named -;;; TYPE-CLASS is also a subtype of the named superclass and of any of -;;; its superclasses. If there are multiple specs, then some will have -;;; guards. We choose the first spec whose guard is a supertype of -;;; TYPE1 and use its superclass. In effect, a sequence of guards -;;; G0, G1, G2 -;;; is actually -;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))). -;;; -;;; WHEN controls when the forms are executed. -(defmacro !define-superclasses (type-class-name specs progn-oid) - (let ((defun-name (symbolicate type-class-name "-COMPLEX-SUBTYPEP-ARG1"))) - `(progn - (defun ,defun-name (type1 type2) - (has-superclasses-complex-subtypep-arg1 - type1 type2 - (load-time-value - (list ,@(mapcar (lambda (spec) - (destructuring-bind (super &optional guard) spec - `(cons (find-classoid ',super) ',guard))) - specs)) #-sb-xc-host t))) - (,progn-oid - (let ((type-class (type-class-or-lose ',type-class-name))) - (setf (type-class-complex-subtypep-arg1 type-class) #',defun-name) - (setf (type-class-complex-subtypep-arg2 type-class) - #'delegate-complex-subtypep-arg2) - (setf (type-class-complex-intersection2 type-class) - #'delegate-complex-intersection2)))))) - -;;;; FUNCTION and VALUES types -;;;; -;;;; Pretty much all of the general type operations are illegal on -;;;; VALUES types, since we can't discriminate using them, do -;;;; SUBTYPEP, etc. FUNCTION types are acceptable to the normal type -;;;; operations, but are generally considered to be equivalent to -;;;; FUNCTION. These really aren't true types in any type theoretic -;;;; sense, but we still parse them into CTYPE structures for two -;;;; reasons: - -;;;; -- Parsing and unparsing work the same way, and indeed we can't -;;;; tell whether a type is a function or values type without -;;;; parsing it. -;;;; -- Many of the places that can be annotated with real types can -;;;; also be annotated with function or values types. - -(define-type-method (values :simple-subtypep :complex-subtypep-arg1) - (type1 type2) - (declare (ignore type2)) - ;; FIXME: should be TYPE-ERROR, here and in next method - (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1))) - -(define-type-method (values :complex-subtypep-arg2) - (type1 type2) - (declare (ignore type1)) - (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2))) - -(define-type-method (values :negate) (type) - (error "NOT VALUES too confusing on ~S" (type-specifier type))) - -(define-type-method (values :unparse) (type) - (cons 'values - (let ((unparsed (unparse-args-types type))) - (if (or (values-type-optional type) - (values-type-rest type) - (values-type-allowp type)) - unparsed - (nconc unparsed '(&optional)))))) - -;;; Return true if LIST1 and LIST2 have the same elements in the same -;;; positions according to TYPE=. We return NIL, NIL if there is an -;;; uncertain comparison. -(defun type=-list (list1 list2) - (declare (list list1 list2)) - (do ((types1 list1 (cdr types1)) - (types2 list2 (cdr types2))) - ((or (null types1) (null types2)) - (if (or types1 types2) - (values nil t) - (values t t))) - (multiple-value-bind (val win) - (type= (first types1) (first types2)) - (unless win - (return (values nil nil))) - (unless val - (return (values nil t)))))) - -(define-type-method (values :simple-=) (type1 type2) - (type=-args type1 type2)) - -;;; a flag that we can bind to cause complex function types to be -;;; unparsed as FUNCTION. This is useful when we want a type that we -;;; can pass to TYPEP. -(defparameter *unparse-fun-type-simplify* nil) ; initialized by genesis - -(define-type-method (function :negate) (type) (make-negation-type type)) - -(define-type-method (function :unparse) (type) - (let ((name (if (fun-designator-type-p type) - 'function-designator - 'function))) - (cond (*unparse-fun-type-simplify* - name) - (t - (list name - (if (fun-type-wild-args type) - '* - (unparse-args-types type)) - (type-specifier - (fun-type-returns type))))))) - -;;; The meaning of this is a little confused. On the one hand, all -;;; function objects are represented the same way regardless of the -;;; arglists and return values, and apps don't get to ask things like -;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the -;;; other hand, Python wants to reason about function types. So... -(define-type-method (function :simple-subtypep) (type1 type2) - (cond ((and (fun-designator-type-p type1) - (not (fun-designator-type-p type2))) - (values nil t)) - ((type= type1 type2) - ;; Since the following doesn't handle &rest or &key at least - ;; pick out equal types. - (values t t)) - (t - (flet ((fun-type-simple-p (type) - (not (or (fun-type-rest type) - (fun-type-keyp type)))) - (every-csubtypep (types1 types2) - (loop - for a1 in types1 - for a2 in types2 - do (multiple-value-bind (res sure-p) - (csubtypep a1 a2) - (unless res (return (values res sure-p)))) - finally (return (values t t))))) - (and/type (values-subtypep (fun-type-returns type1) - (fun-type-returns type2)) - (cond ((fun-type-wild-args type2) (values t t)) - ((fun-type-wild-args type1) - (cond ((fun-type-keyp type2) (values nil nil)) - ((not (fun-type-rest type2)) (values nil t)) - ((not (null (fun-type-required type2))) - (values nil t)) - (t (and/type (type= *universal-type* - (fun-type-rest type2)) - (every/type #'type= - *universal-type* - (fun-type-optional - type2)))))) - ((not (and (fun-type-simple-p type1) - (fun-type-simple-p type2))) - (values nil nil)) - (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) - (multiple-value-bind (min2 max2) (fun-type-nargs type2) - (cond ((or (> max1 max2) (< min1 min2)) - (values nil t)) - ((and (= min1 min2) (= max1 max2)) - (and/type (every-csubtypep - (fun-type-required type1) - (fun-type-required type2)) - (every-csubtypep - (fun-type-optional type1) - (fun-type-optional type2)))) - (t (every-csubtypep - (concatenate 'list - (fun-type-required type1) - (fun-type-optional type1)) - (concatenate 'list - (fun-type-required type2) - (fun-type-optional type2)))))))))))))) - -(!define-superclasses function ((function)) !cold-init-forms) - -;;; The union or intersection of two FUNCTION types is FUNCTION. -(define-type-method (function :simple-union2) (type1 type2) - (if (or (fun-designator-type-p type1) - (fun-designator-type-p type2)) - (specifier-type 'function-designator) - (specifier-type 'function))) - -(define-type-method (function :simple-intersection2) (type1 type2) - (let ((ftype (specifier-type 'function))) - (cond ((eq type1 ftype) type2) - ((eq type2 ftype) type1) - (t (let ((rtype (values-type-intersection (fun-type-returns type1) - (fun-type-returns type2))) - (designator - (and (fun-designator-type-p type1) - (fun-designator-type-p type2)))) - (flet ((change-returns (ftype rtype) - (declare (type fun-type ftype) (type ctype rtype)) - (make-fun-type :required (fun-type-required ftype) - :optional (fun-type-optional ftype) - :keyp (fun-type-keyp ftype) - :keywords (fun-type-keywords ftype) - :allowp (fun-type-allowp ftype) - :returns rtype - :designator designator))) - (cond - ((fun-type-wild-args type1) - (if (fun-type-wild-args type2) - (make-fun-type :wild-args t - :returns rtype - :designator designator) - (change-returns type2 rtype))) - ((fun-type-wild-args type2) - (change-returns type1 rtype)) - (t (multiple-value-bind (req opt rest) - (args-type-op type1 type2 #'type-intersection #'max) - (make-fun-type :required req - :optional opt - :rest rest - ;; FIXME: :keys - :allowp (and (fun-type-allowp type1) - (fun-type-allowp type2)) - :returns rtype - :designator designator)))))))))) - -;;; The union or intersection of a subclass of FUNCTION with a -;;; FUNCTION type is somewhat complicated. -(define-type-method (function :complex-intersection2) (type1 type2) - (cond - ((and (fun-designator-type-p type2) - (or (csubtypep type1 (specifier-type 'symbol)) - (csubtypep type1 (specifier-type 'function)))) - type1) - ((type= type1 (specifier-type 'function)) type2) - ((csubtypep type1 (specifier-type 'function)) nil) - (t :call-other-method))) -(define-type-method (function :complex-union2) (type1 type2) - (declare (ignore type2)) - ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming - ;; FUNCTION, then it is the union of the two; otherwise, there is no - ;; special union. - (cond - ((type= type1 (specifier-type 'function)) type1) - (t nil))) - -(define-type-method (function :simple-=) (type1 type2) - (if (or (and (fun-designator-type-p type1) - (not (fun-designator-type-p type2))) - (and (not (fun-designator-type-p type1)) - (fun-designator-type-p type2))) - (values nil t) - (macrolet ((compare (comparator field) - (let ((reader (symbolicate '#:fun-type- field))) - `(,comparator (,reader type1) (,reader type2))))) - (and/type (compare type= returns) - (cond ((neq (fun-type-wild-args type1) (fun-type-wild-args type2)) - (values nil t)) - ((eq (fun-type-wild-args type1) t) - (values t t)) - (t (type=-args type1 type2))))))) - -(define-type-class constant :inherits values) - -(define-type-method (constant :negate) (type) - (error "NOT CONSTANT too confusing on ~S" (type-specifier type))) - -(define-type-method (constant :unparse) (type) - `(constant-arg ,(type-specifier (constant-type-type type)))) - -(define-type-method (constant :simple-=) (type1 type2) - (type= (constant-type-type type1) (constant-type-type type2))) - -(def-type-translator constant-arg ((:context context) type) - (make-constant-type :type (single-value-specifier-type type context))) - -;;; Return the lambda-list-like type specification corresponding -;;; to an ARGS-TYPE. -(declaim (ftype (function (args-type) list) unparse-args-types)) -(defun unparse-args-types (type) - (collect ((result)) - - (dolist (arg (args-type-required type)) - (result (type-specifier arg))) - - (when (args-type-optional type) - (result '&optional) - (dolist (arg (args-type-optional type)) - (result (type-specifier arg)))) - - (when (args-type-rest type) - (result '&rest) - (result (type-specifier (args-type-rest type)))) - - (when (args-type-keyp type) - (result '&key) - (dolist (key (args-type-keywords type)) - (result (list (key-info-name key) - (type-specifier (key-info-type key)))))) - - (when (args-type-allowp type) - (result '&allow-other-keys)) - - (result))) - -(defun translate-fun-type (context args result - &key designator) - (let ((result (coerce-to-values (basic-parse-typespec result context)))) - (cond ((neq args '*) - (multiple-value-bind (llks required optional rest keywords) - (parse-args-types context args :function-type) - (if (and (null required) - (null optional) - (eq rest *universal-type*) - (not (ll-kwds-keyp llks))) - (if (eq result *wild-type*) - (specifier-type 'function) - (make-fun-type :wild-args t :returns result - :designator designator)) - (make-fun-type :required required - :optional optional - :rest rest - :keyp (ll-kwds-keyp llks) - :keywords keywords - :allowp (ll-kwds-allowp llks) - :returns result - :designator designator)))) - ((eq result *wild-type*) - (if designator - ;; Do not put 'FUNCTION-DESIGNATOR here! - ;; (Since this is the parser for FUNCTION-DESIGNATOR) - (specifier-type '(or function symbol)) - (specifier-type 'function))) - (t - (make-fun-type :wild-args t :returns result - :designator designator))))) - -(def-type-translator function ((:context context) - &optional (args '*) (result '*)) - (translate-fun-type context args result)) - -(def-type-translator function-designator ((:context context) - &optional (args '*) (result '*)) - (translate-fun-type context args result :designator t)) - -(def-type-translator values :list ((:context context) &rest values) - (multiple-value-bind (llks required optional rest) - (parse-args-types context values :values-type) - (if (plusp llks) - (make-values-type :required required :optional optional :rest rest) - (make-short-values-type required)))) - -;;;; VALUES types interfaces -;;;; -;;;; We provide a few special operations that can be meaningfully used -;;;; on VALUES types (as well as on any other type). - -;;; Return the minimum number of values possibly matching VALUES type -;;; TYPE. -(defun values-type-min-value-count (type) - (etypecase type - (named-type - (ecase (named-type-name type) - ((t *) 0) - ((nil) 0))) - (values-type - (length (values-type-required type))))) - -;;; Return the maximum number of values possibly matching VALUES type -;;; TYPE. -(defun values-type-max-value-count (type) - (etypecase type - (named-type - (ecase (named-type-name type) - ((t *) call-arguments-limit) - ((nil) 0))) - (values-type - (if (values-type-rest type) - call-arguments-limit - (+ (length (values-type-optional type)) - (length (values-type-required type))))))) - -(defun values-type-may-be-single-value-p (type) - (<= (values-type-min-value-count type) - 1 - (values-type-max-value-count type))) - -;;; VALUES type with a single value. -(defun type-single-value-p (type) - (and (%values-type-p type) - (not (values-type-rest type)) - (null (values-type-optional type)) - (singleton-p (values-type-required type)))) - -;;; Return the type of the first value indicated by TYPE. This is used -;;; by people who don't want to have to deal with VALUES types. -(declaim (freeze-type values-type)) -; (inline single-value-type)) -(defun single-value-type (type) - (declare (type ctype type)) - (cond ((eq type *wild-type*) - *universal-type*) - ((eq type *empty-type*) - *empty-type*) - ((not (values-type-p type)) - type) - ((car (args-type-required type))) - (t (type-union (specifier-type 'null) - (or (car (args-type-optional type)) - (args-type-rest type) - (specifier-type 'null)))))) - -;;; Return the minimum number of arguments that a function can be -;;; called with, and the maximum number or NIL. If not a function -;;; type, return NIL, NIL. -(defun fun-type-nargs (type) - (declare (type ctype type)) - (if (and (fun-type-p type) (not (fun-type-wild-args type))) - (let ((fixed (length (args-type-required type)))) - (if (or (args-type-rest type) - (args-type-keyp type) - (args-type-allowp type)) - (values fixed nil) - (values fixed (+ fixed (length (args-type-optional type)))))) - (values nil nil))) - -;;; Determine whether TYPE corresponds to a definite number of values. -;;; The first value is a list of the types for each value, and the -;;; second value is the number of values. If the number of values is -;;; not fixed, then return NIL and :UNKNOWN. -(defun values-types (type) - (declare (type ctype type)) - (cond ((or (eq type *wild-type*) (eq type *empty-type*)) - (values nil :unknown)) - ((or (args-type-optional type) - (args-type-rest type)) - (values nil :unknown)) - (t - (let ((req (args-type-required type))) - (values req (length req)))))) - -;;; Return two values: -;;; 1. A list of all the positional (fixed and optional) types. -;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE. -(defun values-type-types (type &optional (default-type *empty-type*)) - (declare (type ctype type)) - (if (eq type *wild-type*) - (values nil *universal-type*) - (values (append (args-type-required type) - (args-type-optional type)) - (or (args-type-rest type) - default-type)))) - -;;; types of values in (the (values o_1 ... o_n)) -(defun values-type-out (type count) - (declare (type ctype type) (type unsigned-byte count)) - (if (eq type *wild-type*) - (make-list count :initial-element *universal-type*) - (collect ((res)) - (flet ((process-types (types) - (loop for type in types - while (plusp count) - do (decf count) - do (res type)))) - (process-types (values-type-required type)) - (process-types (values-type-optional type)) - (let ((rest (values-type-rest type))) - (when rest - (loop repeat count - do (res rest))))) - (res)))) - -;;; types of variable in (m-v-bind (v_1 ... v_n) (the ... -(defun values-type-in (type count) - (declare (type ctype type) (type unsigned-byte count)) - (if (eq type *wild-type*) - (make-list count :initial-element *universal-type*) - (collect ((res)) - (let ((null-type (specifier-type 'null))) - (loop for type in (values-type-required type) - while (plusp count) - do (decf count) - do (res type)) - (loop for type in (values-type-optional type) - while (plusp count) - do (decf count) - do (res (type-union type null-type))) - (when (plusp count) - (loop with rest = (acond ((values-type-rest type) - (type-union it null-type)) - (t null-type)) - repeat count - do (res rest)))) - (res)))) - -;;; Return a list of OPERATION applied to the types in TYPES1 and -;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter -;;; than TYPES2. The second value is T if OPERATION always returned a -;;; true second value. -(defun fixed-values-op (types1 types2 rest2 operation) - (declare (list types1 types2) (type ctype rest2) (type function operation)) - (let ((exact t)) - (values (mapcar (lambda (t1 t2) - (multiple-value-bind (res win) - (funcall operation t1 t2) - (unless win - (setq exact nil)) - res)) - types1 - (append types2 - (make-list (- (length types1) (length types2)) - :initial-element rest2))) - exact))) - -;;; If TYPE isn't a values type, then make it into one. -(defun-cached (%coerce-to-values :hash-bits 8 :hash-function #'type-hash-value) - ((type eq)) - (cond ((multiple-value-bind (res sure) - (csubtypep (specifier-type 'null) type) - (and (not res) sure)) - ;; FIXME: What should we do with (NOT SURE)? - (make-values-type :required (list type) :rest *universal-type*)) - (t - (make-values-type :optional (list type) :rest *universal-type*)))) - -(defun coerce-to-values (type) - (declare (type ctype type)) - (cond ((or (eq type *universal-type*) - (eq type *wild-type*)) - *wild-type*) - ((values-type-p type) - type) - (t (%coerce-to-values type)))) - -;;; Return type, corresponding to ANSI short form of VALUES type -;;; specifier. -(defun make-short-values-type (types) - (declare (list types)) - (let ((last-required (position-if - (lambda (type) - (not/type (csubtypep (specifier-type 'null) type))) - types - :from-end t))) - (if last-required - (make-values-type :required (subseq types 0 (1+ last-required)) - :optional (subseq types (1+ last-required)) - :rest *universal-type*) - (make-values-type :optional types :rest *universal-type*)))) - -(defun make-single-value-type (type) - (make-values-type :required (list type))) - -;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any -;;; type, including VALUES types. With VALUES types such as: -;;; (VALUES a0 a1) -;;; (VALUES b0 b1) -;;; we compute the more useful result -;;; (VALUES ( a0 b0) ( a1 b1)) -;;; rather than the precise result -;;; ( (values a0 a1) (values b0 b1)) -;;; This has the virtue of always keeping the VALUES type specifier -;;; outermost, and retains all of the information that is really -;;; useful for static type analysis. We want to know what is always -;;; true of each value independently. It is worthless to know that if -;;; the first value is B0 then the second will be B1. -;;; -;;; If the VALUES count signatures differ, then we produce a result with -;;; the required VALUE count chosen by NREQ when applied to the number -;;; of required values in TYPE1 and TYPE2. Any &KEY values become -;;; &REST T (anyone who uses keyword values deserves to lose.) -;;; -;;; The second value is true if the result is definitely empty or if -;;; OPERATION returned true as its second value each time we called -;;; it. Since we approximate the intersection of VALUES types, the -;;; second value being true doesn't mean the result is exact. -(defun args-type-op (type1 type2 operation nreq) - (declare (type ctype type1 type2) - (type function operation nreq)) - (when (eq type1 type2) - (values type1 t)) - (multiple-value-bind (types1 rest1) - (values-type-types type1) - (multiple-value-bind (types2 rest2) - (values-type-types type2) - (multiple-value-bind (rest rest-exact) - (funcall operation rest1 rest2) - (multiple-value-bind (res res-exact) - (if (< (length types1) (length types2)) - (fixed-values-op types2 types1 rest1 operation) - (fixed-values-op types1 types2 rest2 operation)) - (let* ((req (funcall nreq - (length (args-type-required type1)) - (length (args-type-required type2)))) - (required (subseq res 0 req)) - (opt (subseq res req))) - (values required opt rest - (and rest-exact res-exact)))))))) - -(defun values-type-op (type1 type2 operation nreq) - (multiple-value-bind (required optional rest exactp) - (args-type-op type1 type2 operation nreq) - (values (make-values-type :required required - :optional optional - :rest rest) - exactp))) - -(defun compare-key-args (type1 type2) - (let ((keys1 (args-type-keywords type1)) - (keys2 (args-type-keywords type2))) - (and (= (length keys1) (length keys2)) - (eq (args-type-allowp type1) - (args-type-allowp type2)) - (loop for key1 in keys1 - for match = (find (key-info-name key1) - keys2 :key #'key-info-name) - always (and match - (type= (key-info-type key1) - (key-info-type match))))))) - -(defun type=-args (type1 type2) - (macrolet ((compare (comparator field) - (let ((reader (symbolicate '#:args-type- field))) - `(,comparator (,reader type1) (,reader type2))))) - (and/type - (cond ((null (args-type-rest type1)) - (values (null (args-type-rest type2)) t)) - ((null (args-type-rest type2)) - (values nil t)) - (t - (compare type= rest))) - (and/type (and/type (compare type=-list required) - (compare type=-list optional)) - (if (or (args-type-keyp type1) (args-type-keyp type2)) - (values (compare-key-args type1 type2) t) - (values t t)))))) - -;;; Do a union or intersection operation on types that might be values -;;; types. The result is optimized for utility rather than exactness, -;;; but it is guaranteed that it will be no smaller (more restrictive) -;;; than the precise result. -;;; -;;; The return convention seems to be analogous to -;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910. -(defun-cached (values-type-union :hash-function #'type-cache-hash - :hash-bits 8) - ((type1 eq) (type2 eq)) - (declare (type ctype type1 type2)) - (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*) - ((eq type1 *empty-type*) type2) - ((eq type2 *empty-type*) type1) - (t - (values (values-type-op type1 type2 #'type-union #'min))))) - -(defun-cached (values-type-intersection :hash-function #'type-cache-hash - :hash-bits 8) - ((type1 eq) (type2 eq)) - (declare (type ctype type1 type2)) - (cond ((eq type1 *wild-type*) - (coerce-to-values type2)) - ((or (eq type2 *wild-type*) (eq type2 *universal-type*)) - type1) - ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) - *empty-type*) - ((and (not (values-type-p type2)) - (values-type-required type1)) - (let ((req1 (values-type-required type1))) - (make-values-type :required (cons (type-intersection (first req1) type2) - (rest req1)) - :optional (values-type-optional type1) - :rest (values-type-rest type1) - :allowp (values-type-allowp type1)))) - (t - (values (values-type-op type1 (coerce-to-values type2) - #'type-intersection - #'max))))) - -;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of -;;; works on VALUES types. Note that due to the semantics of -;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when -;;; there isn't really any intersection. -(defun values-types-equal-or-intersect (type1 type2) - (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) - (values t t)) - ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) - (values t t)) - (t - (let ((res (values-type-intersection type1 type2))) - (values (not (eq res *empty-type*)) - t))))) - -;;; a SUBTYPEP-like operation that can be used on any types, including -;;; VALUES types -(defun-cached (values-subtypep :hash-function #'type-cache-hash - :hash-bits 8 - :values 2) - ((type1 eq) (type2 eq)) - (declare (type ctype type1 type2)) - (cond ((or (eq type2 *wild-type*) (eq type2 *universal-type*) - (eq type1 *empty-type*)) - (values t t)) - ((eq type1 *wild-type*) - (values (eq type2 *wild-type*) t)) - ((or (eq type2 *empty-type*) - (not (values-types-equal-or-intersect type1 type2))) - (values nil t)) - ((and (not (values-type-p type2)) - (values-type-required type1)) - (csubtypep (first (values-type-required type1)) - type2)) - (t (setq type2 (coerce-to-values type2)) - (multiple-value-bind (types1 rest1) (values-type-types type1) - (multiple-value-bind (types2 rest2) (values-type-types type2) - (cond ((< (length (values-type-required type1)) - (length (values-type-required type2))) - (values nil t)) - ((< (length types1) (length types2)) - (values nil nil)) - (t - (do ((t1 types1 (rest t1)) - (t2 types2 (rest t2))) - ((null t2) - (csubtypep rest1 rest2)) - (multiple-value-bind (res win-p) - (csubtypep (first t1) (first t2)) - (unless win-p - (return (values nil nil))) - (unless res - (return (values nil t)))))))))))) - -;;;; type method interfaces - -;;; like SUBTYPEP, only works on CTYPE structures -(defun-cached (csubtypep :hash-function #'type-cache-hash - :hash-bits 10 - :memoizer memoize - :values 2) - ((type1 eq) (type2 eq)) - (declare (type ctype type1 type2)) - (cond ((or (eq type1 type2) - (eq type1 *empty-type*) - (eq type2 *universal-type*)) - (values t t)) - #+nil - ((eq type1 *universal-type*) - (values nil t)) - (t - (memoize - (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 - type1 type2 - :complex-arg1 :complex-subtypep-arg1))))) - -;;; Just parse the type specifiers and call CSUBTYPE. -;;; Well, not "just" - Despite memoization of parsing and CSUBTYPEP, -;;; it's nonetheless better to test EQUAL first, which is ~10x faster -;;; in the positive case, and insigificant in the negative. -;;; The specifiers might not be legal type specifiers, -;;; but we're not obligated to police that: -;;; "This version eliminates the requirement to signal an error." -;;; http://www.lispworks.com/documentation/HyperSpec/Issues/iss335_w.htm -;;; (Status: Passed, as amended, Jun89 X3J13) -;;; -;;; Also, inferring from the version of the text that was obsoleted -;;; - which while it has no direct impact on the final requirement, -;;; implies something about what would have been legal - -;;; "SUBTYPEP must always return values T T in the case where the two -;;; type specifiers (or their expansions) are EQUAL." -;;; i.e. though it is not longer technically a MUST, it suggests that EQUAL is -;;; in fact a valid implementation, at least where it computes T. -(defun subtypep (type1 type2 &optional environment) - "Return two values indicating the relationship between type1 and type2. - If values are T and T, type1 definitely is a subtype of type2. - If values are NIL and T, type1 definitely is not a subtype of type2. - If values are NIL and NIL, it couldn't be determined." - (declare (type lexenv-designator environment) (ignore environment)) - (declare (explicit-check)) - (if (equal type1 type2) - (values t t) - (csubtypep (specifier-type type1) (specifier-type type2)))) - -(declaim (inline ctype-eq-comparable)) -(defun ctype-eq-comparable (ctype) - (logtest (type-hash-value ctype) +type-admits-type=-optimization+)) - -(defun ctype-interned-p (ctype) - (logtest (type-hash-value ctype) +type-internedp+)) - -#-sb-devel -(declaim (start-block)) - -;;; If two types are definitely equivalent, return true. The second -;;; value indicates whether the first value is definitely correct. -;;; This should only fail in the presence of HAIRY types. -(defun-cached (type= :hash-function #'type-cache-hash - :hash-bits 11 - :memoizer memoize - :values 2) - ((type1 eq) (type2 eq)) - (declare (type ctype type1 type2)) - (cond ((eq type1 type2) - (values t t)) - ;; If args are not EQ, but both allow TYPE= optimization, - ;; and at least one is interned, then return no and certainty. - ;; Most of the interned CTYPEs admit this optimization, - ;; NUMERIC and MEMBER types do as well. - ((and (logtest +type-internedp+ - (logior (type-hash-value type1) (type-hash-value type2))) - (logtest +type-admits-type=-optimization+ - (logand (type-hash-value type1) (type-hash-value type2)))) - (values nil t)) - (t - (memoize (!invoke-type-method :simple-= :complex-= type1 type2))))) - -;;; Not exactly the negation of TYPE=, since when the relationship is -;;; uncertain, we still return NIL, NIL. This is useful in cases where -;;; the conservative assumption is =. -(defun type/= (type1 type2) - (declare (type ctype type1 type2)) - (multiple-value-bind (res win) (type= type1 type2) - (if win - (values (not res) t) - (values nil nil)))) - -(declaim (end-block)) - -;;; the type method dispatch case of TYPE-UNION2 -(defun %type-union2 (type1 type2) - ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give - ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike - ;; %TYPE-INTERSECTION2, though, I don't have a specific case which - ;; demonstrates this is actually necessary. Also unlike - ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish - ;; between not finding a method and having a method return NIL. - (flet ((1way (x y) - (!invoke-type-method :simple-union2 :complex-union2 - x y - :default nil))) - (declare (inline 1way)) - (or (1way type1 type2) - (1way type2 type1)))) - -;;; Find a type which includes both types. Any inexactness is -;;; represented by the fuzzy element types; we return a single value -;;; that is precise to the best of our knowledge. This result is -;;; simplified into the canonical form, thus is not a UNION-TYPE -;;; unless we find no other way to represent the result. -(defun-cached (type-union2 :hash-function #'type-cache-hash - :hash-bits 11 - :memoizer memoize) - ((type1 eq) (type2 eq)) - ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And - ;; Paste technique of programming. If it stays around (as opposed to - ;; e.g. fading away in favor of some CLOS solution) the shared logic - ;; should probably become shared code. -- WHN 2001-03-16 - (declare (type ctype type1 type2)) - (let ((t2 nil)) - (if (eq type1 type2) - type1 - (memoize - (cond - ;; CSUBTYPEP for array-types answers questions about the - ;; specialized type, yet for union we want to take the - ;; expressed type in account too. - ((and (not (and (array-type-p type1) (array-type-p type2))) - (or (setf t2 (csubtypep type1 type2)) - (csubtypep type2 type1))) - (if t2 type2 type1)) - ((or (union-type-p type1) - (union-type-p type2)) - ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES - ;; values broken out and united separately. The full TYPE-UNION - ;; function knows how to do this, so let it handle it. - (type-union type1 type2)) - (t - ;; the ordinary case: we dispatch to type methods - (%type-union2 type1 type2))))))) - -;;; the type method dispatch case of TYPE-INTERSECTION2 -(defun %type-intersection2 (type1 type2) - ;; We want to give both argument orders a chance at - ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type - ;; methods could give noncommutative results, e.g. - ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE) - ;; => NIL, NIL - ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*) - ;; => #, T - ;; We also need to distinguish between the case where we found a - ;; type method, and it returned NIL, and the case where we fell - ;; through without finding any type method. An example of the first - ;; case is the intersection of a HAIRY-TYPE with some ordinary type. - ;; An example of the second case is the intersection of two - ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and - ;; ARRAY. - ;; - ;; (Why yes, CLOS probably *would* be nicer..) - (flet ((1way (x y) - (!invoke-type-method :simple-intersection2 :complex-intersection2 - x y - :default :call-other-method))) - (declare (inline 1way)) - (let ((xy (1way type1 type2))) - (or (and (not (eql xy :call-other-method)) xy) - (let ((yx (1way type2 type1))) - (or (and (not (eql yx :call-other-method)) yx) - (cond ((and (eql xy :call-other-method) - (eql yx :call-other-method)) - *empty-type*) - (t - nil)))))))) - -(defun-cached (type-intersection2 :hash-function #'type-cache-hash - :hash-bits 11 - :memoizer memoize - :values 1) - ((type1 eq) (type2 eq)) - (declare (type ctype type1 type2)) - (if (eq type1 type2) - ;; FIXME: For some reason, this doesn't catch e.g. type1 = - ;; type2 = (SPECIFIER-TYPE - ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 - type1 - (memoize - (cond - ((or (intersection-type-p type1) - (intersection-type-p type2)) - ;; Intersections of INTERSECTION-TYPE should have the - ;; INTERSECTION-TYPE-TYPES values broken out and intersected - ;; separately. The full TYPE-INTERSECTION function knows how - ;; to do that, so let it handle it. - (type-intersection type1 type2)) - (t - ;; the ordinary case: we dispatch to type methods - (%type-intersection2 type1 type2)))))) - -;;; Return as restrictive and simple a type as we can discover that is -;;; no more restrictive than the intersection of TYPE1 and TYPE2. At -;;; worst, we arbitrarily return one of the arguments as the first -;;; value (trying not to return a hairy type). -(defun type-approx-intersection2 (type1 type2) - (cond ((type-intersection2 type1 type2)) - ((hairy-type-p type1) type2) - (t type1))) - -;;; a test useful for checking whether a derived type matches a -;;; declared type -;;; -;;; The first value is true unless the types don't intersect and -;;; aren't equal. The second value is true if the first value is -;;; definitely correct. NIL is considered to intersect with any type. -;;; If T is a subtype of either type, then we also return T, T. This -;;; way we recognize that hairy types might intersect with T. -;;; -;;; Well now given the statement above that this is "useful for ..." -;;; a particular thing, I see how treating *empty-type* magically could -;;; be useful, however given all the _other_ calls to this function within -;;; this file, it seems suboptimal, because logically it is wrong. -(defun types-equal-or-intersect (type1 type2) - (declare (type ctype type1 type2)) - (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) - (values t t) - (let ((intersection2 (type-intersection2 type1 type2))) - (cond ((not intersection2) - (if (or (csubtypep *universal-type* type1) - (csubtypep *universal-type* type2)) - (values t t) - (values t nil))) - ((eq intersection2 *empty-type*) (values nil t)) - (t (values t t)))))) - -;;; Return a Common Lisp type specifier corresponding to the TYPE -;;; object. -(defun type-specifier (type) - (declare (type ctype type)) - (funcall (type-class-unparse (type-class type)) type)) - -;;; Don't try to define a print method until it's actually gonna work! -;;; (Otherwise this would be near the DEFSTRUCT) -(defmethod print-object ((ctype ctype) stream) - (print-unreadable-object (ctype stream :type t) - (prin1 (type-specifier ctype) stream))) - -(defun-cached (type-negation :hash-function #'type-hash-value - :hash-bits 8 - :values 1) - ((type eq)) - (declare (type ctype type)) - (funcall (type-class-negate (type-class type)) type)) - -(defun-cached (type-singleton-p :hash-function #'type-hash-value - :hash-bits 8 - :values 2) - ((type eq)) - (declare (type ctype type)) - (let ((function (type-class-singleton-p (type-class type)))) - (if function - (funcall function type) - (values nil nil)))) - -;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to -;;; early-type.lisp by WHN ca. 19990201.) - -;;; Take a list of type specifiers, computing the translation of each -;;; specifier and defining it as a builtin type. -;;; Seee the comments in 'type-init' for why this is a slightly -;;; screwy way to go about it. -(declaim (ftype (function (list) (values)) !precompute-types)) -(defun !precompute-types (specs) - (dolist (spec specs) - (let ((res (handler-bind - ((parse-unknown-type - (lambda (c) - (declare (ignore c)) - ;; We can handle conditions at this point, - ;; but win32 can not perform i/o here because - ;; !MAKE-COLD-STDERR-STREAM has no implementation. - ;; FIXME: where is this coming from??? - #+nil - (progn (write-string "//caught: parse-unknown ") - (write spec) - (terpri))))) - (specifier-type spec)))) - (unless (unknown-type-p res) - (setf (info :type :builtin spec) res) - (setf (info :type :kind spec) :primitive)))) - (values)) - -;;;; general TYPE-UNION and TYPE-INTERSECTION operations -;;;; -;;;; These are fully general operations on CTYPEs: they'll always -;;;; return a CTYPE representing the result. - -;;; shared logic for unions and intersections: Return a list of -;;; types representing the same types as INPUT-TYPES, but with -;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their -;;; component types, and with any SIMPLY2 simplifications applied. -(macrolet - ((def (name compound-type-p simplify2) - `(defun ,name (types) - (when types - (multiple-value-bind (first rest) - (if (,compound-type-p (car types)) - (values (car (compound-type-types (car types))) - (append (cdr (compound-type-types (car types))) - (cdr types))) - (values (car types) (cdr types))) - (let ((rest (,name rest)) u) - (dolist (r rest (cons first rest)) - (when (setq u (,simplify2 first r)) - (return (,name (nsubstitute u r rest))))))))))) - (def simplify-intersections intersection-type-p type-intersection2) - (def simplify-unions union-type-p type-union2)) - -(defun maybe-distribute-one-union (union-type types) - (let* ((intersection (%type-intersection types)) - (union (mapcar (lambda (x) (type-intersection x intersection)) - (union-type-types union-type)))) - (if (notany (lambda (x) (or (hairy-type-p x) - (intersection-type-p x))) - union) - union - nil))) - -(defun type-intersection (&rest input-types) - (%type-intersection input-types)) -(defun-cached (%type-intersection :hash-bits 10 :hash-function #'type-list-cache-hash) - ((input-types equal)) - (let ((simplified-types (simplify-intersections input-types))) - (declare (type list simplified-types)) - ;; We want to have a canonical representation of types (or failing - ;; that, punt to HAIRY-TYPE). Canonical representation would have - ;; intersections inside unions but not vice versa, since you can - ;; always achieve that by the distributive rule. But we don't want - ;; to just apply the distributive rule, since it would be too easy - ;; to end up with unreasonably huge type expressions. So instead - ;; we try to generate a simple type by distributing the union; if - ;; the type can't be made simple, we punt to HAIRY-TYPE. - (if (and (cdr simplified-types) (some #'union-type-p simplified-types)) - (let* ((first-union (find-if #'union-type-p simplified-types)) - (other-types (coerce (remove first-union simplified-types) - 'list)) - (distributed (maybe-distribute-one-union first-union - other-types))) - (if distributed - (%type-union distributed) - (%make-hairy-type `(and ,@(map 'list #'type-specifier - simplified-types))))) - (cond - ((null simplified-types) *universal-type*) - ((null (cdr simplified-types)) (car simplified-types)) - (t (%make-intersection-type - (some #'type-enumerable simplified-types) - simplified-types)))))) - -(defun type-union (&rest input-types) - (%type-union input-types)) -(defun-cached (%type-union :hash-bits 8 :hash-function #'type-list-cache-hash) - ((input-types equal)) - (let ((simplified-types (simplify-unions input-types))) - (cond - ((null simplified-types) *empty-type*) - ((null (cdr simplified-types)) (car simplified-types)) - (t (make-union-type - (every #'type-enumerable simplified-types) - simplified-types))))) - -;;;; built-in types - -(define-type-method (named :simple-=) (type1 type2) - ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. - (values (eq type1 type2) t)) - -(defun cons-type-might-be-empty-type (type) - (declare (type cons-type type)) - (let ((car-type (cons-type-car-type type)) - (cdr-type (cons-type-cdr-type type))) - (or - (if (cons-type-p car-type) - (cons-type-might-be-empty-type car-type) - (multiple-value-bind (yes surep) - (type= car-type *empty-type*) - (aver (not yes)) - (not surep))) - (if (cons-type-p cdr-type) - (cons-type-might-be-empty-type cdr-type) - (multiple-value-bind (yes surep) - (type= cdr-type *empty-type*) - (aver (not yes)) - (not surep)))))) - -(defun cons-type-length-info (type) - (declare (type cons-type type)) - (do ((min 1 (1+ min)) - (cdr (cons-type-cdr-type type) (cons-type-cdr-type cdr))) - ((not (cons-type-p cdr)) - (cond - ((csubtypep cdr (specifier-type 'null)) - (values min t)) - ((csubtypep *universal-type* cdr) - (values min nil)) - ((type/= (type-intersection (specifier-type 'cons) cdr) *empty-type*) - (values min nil)) - ((type/= (type-intersection (specifier-type 'null) cdr) *empty-type*) - (values min t)) - (t (values min :maybe)))) - ())) - -(define-type-method (named :complex-=) (type1 type2) - (cond - ((and (eq type2 *empty-type*) - (or (and (intersection-type-p type1) - ;; not allowed to be unsure on these... FIXME: keep - ;; the list of CL types that are intersection types - ;; once and only once. - (not (or (type= type1 (specifier-type 'ratio)) - (type= type1 (specifier-type 'keyword))))) - (and (cons-type-p type1) - (cons-type-might-be-empty-type type1)))) - ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION - ;; STREAM) can get here. In general, we can't really tell - ;; whether these are equal to NIL or not, so - (values nil nil)) - ((type-might-contain-other-types-p type1) - (invoke-complex-=-other-method type1 type2)) - (t (values nil t)))) - -(define-type-method (named :simple-subtypep) (type1 type2) - (aver (not (eq type1 *wild-type*))) ; * isn't really a type. - (aver (not (eq type1 type2))) - (values (or (eq type1 *empty-type*) - (eq type2 *wild-type*) - (eq type2 *universal-type*)) t)) - -(define-type-method (named :complex-subtypep-arg1) (type1 type2) - ;; This AVER causes problems if we write accurate methods for the - ;; union (and possibly intersection) types which then delegate to - ;; us; while a user shouldn't get here, because of the odd status of - ;; *wild-type* a type-intersection executed by the compiler can. - - ;; CSR, 2002-04-10 - ;; - ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type. - (cond ((eq type1 *empty-type*) - t) - (;; When TYPE2 might be the universal type in disguise - (type-might-contain-other-types-p type2) - ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods - ;; can delegate to us (more or less as CALL-NEXT-METHOD) when - ;; they're uncertain, we can't just barf on COMPOUND-TYPE and - ;; HAIRY-TYPEs as we used to. Instead we deal with the - ;; problem (where at least part of the problem is cases like - ;; (SUBTYPEP T '(SATISFIES FOO)) - ;; or - ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) - ;; where the second type is a hairy type like SATISFIES, or - ;; is a compound type which might contain a hairy type) by - ;; returning uncertainty. - (values nil nil)) - ((eq type1 *funcallable-instance-type*) - (values (eq type2 (specifier-type 'function)) t)) - (t - ;; This case would have been picked off by the SIMPLE-SUBTYPEP - ;; method, and so shouldn't appear here. - (aver (not (named-type-p type2))) - ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another - ;; named type in disguise, TYPE2 is not a superset of TYPE1. - (values nil t)))) - -;;; Return T if members of this classoid certainly have INSTANCE-POINTER-LOWTAG. -;;; Logically it is the near opposite of CLASSOID-NON-INSTANCE-P, but not quite. -;;; CTYPEs which are not represented as a classoid return NIL for both predicates -;;; as do PCL types which may be either funcallable or non-funcallable. -;;; -;;; But some of that generality seems wrong. I don't think it would be allowed -;;; to have (as merely an example) an EQL-SPECIALIZER which is funcallable, -;;; having FUN-POINTER-LOWTAG instead of INSTANCE-POINTER-LOWTAG). Yet we think -;;; it could happen, because the parse of the type (AND EQL-SPECIALIZER INSTANCE) -;;; yields # -;;; versus simplifying down to EQL-SPECIALIZER. -#| (loop for c being each hash-key of (classoid-subclasses (find-classoid 't)) - do (let ((not-i (classoid-non-instance-p c)) - (i (classoid-definitely-instancep c))) - (unless (eq (not not-i) i) (format t "~S -> ~A and ~A~%" c not-i i)))) |# -(defun classoid-definitely-instancep (x) - (or (structure-classoid-p x) - (condition-classoid-p x) - ;; PATHNAMEs are INSTANCEs based on the lowtag criterion - (or (eq x (specifier-type 'logical-pathname)) - (eq x (specifier-type 'pathname))))) -(eval-when (:compile-toplevel :execute) - (pushnew 'classoid-definitely-instancep sb-vm::*backend-cross-foldable-predicates*)) - -(defun classoid-is-or-inherits (sub super) - (or (classoid-inherits-from sub super) - (eq sub (find-classoid super)))) - -(define-type-method (named :complex-subtypep-arg2) (type1 type2) - (aver (not (eq type2 *wild-type*))) ; * isn't really a type. - (cond ((eq type2 *universal-type*) - (values t t)) - ;; some CONS types can conceal danger - ((and (cons-type-p type1) (cons-type-might-be-empty-type type1)) - (values nil nil)) - ((type-might-contain-other-types-p type1) - ;; those types can be other types in disguise. So we'd - ;; better delegate. - (invoke-complex-subtypep-arg1-method type1 type2)) - ((and (or (eq type2 *instance-type*) - (eq type2 *funcallable-instance-type*)) - (member-type-p type1)) - ;; member types can be subtypep INSTANCE and - ;; FUNCALLABLE-INSTANCE in surprising ways. - (invoke-complex-subtypep-arg1-method type1 type2)) - ((and (eq type2 *extended-sequence-type*) (classoid-p type1)) - (values (if (classoid-inherits-from type1 'sequence) t nil) t)) - ((and (eq type2 *instance-type*) (classoid-p type1)) - (cond ((or (classoid-non-instance-p type1) - (classoid-is-or-inherits type1 'function)) - (values nil t)) - ((classoid-definitely-instancep type1) - (values t t)) - (t - (values nil nil)))) - ((and (eq type2 *funcallable-instance-type*) (classoid-p type1)) - (if (and (not (classoid-non-instance-p type1)) - (classoid-inherits-from type1 'function)) - (values t t) - (values nil t))) - (t - ;; FIXME: This seems to rely on there only being 4 or 5 - ;; NAMED-TYPE values, and the exclusion of various - ;; possibilities above. It would be good to explain it and/or - ;; rewrite it so that it's clearer. - (values nil t)))) - -(define-type-method (named :simple-intersection2) (type1 type2) - (cond - ((and (eq type1 *extended-sequence-type*) - (or (eq type2 *instance-type*) - (eq type2 *funcallable-instance-type*))) - nil) - ((and (or (eq type1 *instance-type*) - (eq type1 *funcallable-instance-type*)) - (eq type2 *extended-sequence-type*)) - nil) - (t - (hierarchical-intersection2 type1 type2)))) - -(define-type-method (named :complex-intersection2) (type1 type2) - ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13. - ;; Perhaps when bug 85 is fixed it can be reenabled. - ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. - (flet ((empty-unless-hairy (type) - (unless (or (type-might-contain-other-types-p type) - (member-type-p type)) - *empty-type*))) - (cond - ((eq type2 *extended-sequence-type*) - (typecase type1 - ((satisfies classoid-definitely-instancep) *empty-type*) ; dubious! - (classoid (cond - ((classoid-non-instance-p type1) *empty-type*) - ((classoid-inherits-from type1 'sequence) type1))) - (t (empty-unless-hairy type1)))) - ((eq type2 *instance-type*) - (typecase type1 - ((satisfies classoid-definitely-instancep) type1) - (classoid (when (or (classoid-non-instance-p type1) - (classoid-is-or-inherits type1 'function)) - *empty-type*)) - (t (empty-unless-hairy type1)))) - ((eq type2 *funcallable-instance-type*) - (typecase type1 - ((satisfies classoid-definitely-instancep) *empty-type*) - (classoid - (cond - ((classoid-non-instance-p type1) *empty-type*) - ((classoid-inherits-from type1 'function) type1) - ((type= type1 (find-classoid 'function)) type2))) - (fun-type nil) - (t (empty-unless-hairy type1)))) - (t (hierarchical-intersection2 type1 type2))))) - -(define-type-method (named :complex-union2) (type1 type2) - ;; Perhaps when bug 85 is fixed this can be reenabled. - ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. - (cond - ((eq type2 *extended-sequence-type*) - (cond ((not (classoid-p type1)) nil) - ((and (not (classoid-non-instance-p type1)) - (classoid-inherits-from type1 'sequence)) - type2))) - ((eq type2 *instance-type*) - (when (and (classoid-p type1) - (neq type1 (specifier-type 'function)) - (not (classoid-non-instance-p type1)) - (not (classoid-inherits-from type1 'function))) - type2)) - ((eq type2 *funcallable-instance-type*) - (cond ((not (classoid-p type1)) nil) - ((classoid-non-instance-p type1) nil) - ((not (classoid-inherits-from type1 'function)) nil) - ((eq type1 (specifier-type 'function)) type1) - (t type2))) - (t (hierarchical-union2 type1 type2)))) - -(define-type-method (named :negate) (x) - (aver (not (eq x *wild-type*))) - (cond - ((eq x *universal-type*) *empty-type*) - ((eq x *empty-type*) *universal-type*) - ((or (eq x *instance-type*) - (eq x *funcallable-instance-type*) - (eq x *extended-sequence-type*)) - (make-negation-type x)) - (t (bug "NAMED type unexpected: ~S" x)))) - -(define-type-method (named :unparse) (x) - (named-type-name x)) - -;;;; hairy and unknown types -;;;; DEFINE-TYPE-CLASS HAIRY is in 'early-type' - -(define-type-method (hairy :negate) (x) (make-negation-type x)) - -(define-type-method (hairy :unparse) (x) - (hairy-type-specifier x)) - -(define-type-method (hairy :simple-subtypep) (type1 type2) - (let ((hairy-spec1 (hairy-type-specifier type1)) - (hairy-spec2 (hairy-type-specifier type2))) - (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) - (values t t)) - ((maybe-reparse-specifier! type1) - (csubtypep type1 type2)) - ((maybe-reparse-specifier! type2) - (csubtypep type1 type2)) - (t - (values nil nil))))) - -(define-type-method (hairy :complex-subtypep-arg2) (type1 type2) - (if (maybe-reparse-specifier! type2) - (csubtypep type1 type2) - (let ((specifier (hairy-type-specifier type2))) - (cond ((and (consp specifier) (eql (car specifier) 'satisfies)) - (case (cadr specifier) - ((keywordp) (if (type= type1 (specifier-type 'symbol)) - (values nil t) - (invoke-complex-subtypep-arg1-method type1 type2))) - (t (invoke-complex-subtypep-arg1-method type1 type2)))) - (t - (invoke-complex-subtypep-arg1-method type1 type2)))))) - -(define-type-method (hairy :complex-subtypep-arg1) (type1 type2) - (if (maybe-reparse-specifier! type1) - (csubtypep type1 type2) - (values nil nil))) - -(define-type-method (hairy :complex-=) (type1 type2) - (if (maybe-reparse-specifier! type2) - (type= type1 type2) - (values nil nil))) - -(define-type-method (hairy :simple-intersection2 :complex-intersection2) - (type1 type2) - (acond ((type= type1 type2) - type1) - ((eq type2 (literal-ctype *satisfies-keywordp-type*)) - ;; (AND (MEMBER A) (SATISFIES KEYWORDP)) is possibly non-empty - ;; if A is re-homed as :A. However as a special case that really - ;; does occur, (AND (MEMBER NIL) (SATISFIES KEYWORDP)) - ;; is empty because of the illegality of changing NIL's package. - (if (eq type1 (specifier-type 'null)) - *empty-type* - (multiple-value-bind (answer certain) - (types-equal-or-intersect type1 (specifier-type 'symbol)) - (and (not answer) certain *empty-type*)))) - ((eq type2 (literal-ctype *fun-name-type*)) - (multiple-value-bind (answer certain) - (types-equal-or-intersect type1 (specifier-type 'symbol)) - (and (not answer) - certain - (multiple-value-bind (answer certain) - (types-equal-or-intersect type1 (specifier-type 'cons)) - (and (not answer) certain *empty-type*))))) - ((and (typep (hairy-type-specifier type2) '(cons (eql satisfies))) - (info :function :predicate-truth-constraint - (cadr (hairy-type-specifier type2)))) - (multiple-value-bind (answer certain) - (types-equal-or-intersect type1 (specifier-type it)) - (and (not answer) certain *empty-type*))))) - -(define-type-method (hairy :simple-union2) - (type1 type2) - (if (type= type1 type2) - type1 - nil)) - -(define-type-method (hairy :simple-=) (type1 type2) - (if (equal-but-no-car-recursion (hairy-type-specifier type1) - (hairy-type-specifier type2)) - (values t t) - (values nil nil))) - -;;; This list exists so that we can turn builtin (SATISFIES fn) types into types -;;; amenable to algebra, because apparently there are some masochistic users -;;; who expect (SUBTYPEP 'COMPLEX '(AND NUMBER (SATISFIES REALP))) => NIL and T. -;;; There are possibly other entries that could go here, -;;; e.g. (SATISFIES ARRAY-HEADER-P) is something involving the AND, NOT, OR -;;; combinators. But it might render the expression too hairy to operate on. -(dolist (pair '((arrayp array) - (atom atom) - (bit-vector-p bit-vector) - (characterp character) - (compiled-function-p compiled-function) - (complexp complex) - (consp cons) - (floatp float) - (functionp function) - (hash-table-p hash-table) - (integerp integer) - ;; KEYWORD is (SATISFIES KEYWORDP), so we can't turn - ;; the predicate into KEYWORD - (listp list) - (numberp number) - (packagep package) - (pathnamep pathname) - (random-state-p random-state) - (rationalp rational) - (readtablep readtable) - (realp real) - (simple-bit-vector-p simple-bit-vector) - (simple-string-p simple-string) - (simple-vector-p simple-vector) - (streamp stream) - (stringp string) - (symbolp symbol) - (vectorp vector))) - (destructuring-bind (function type) pair - (setf (info :function :predicate-for function) type))) - -(def-type-translator satisfies :list (&whole whole predicate-name) - ;; "* may appear as the argument to a SATISFIES type specifier, but it - ;; indicates the literal symbol *" (which in practice is not useful) - (unless (symbolp predicate-name) - (error 'simple-type-error - :datum predicate-name - :expected-type 'symbol - :format-control "The SATISFIES predicate name is not a symbol: ~S" - :format-arguments (list predicate-name))) - (case predicate-name - (keywordp (literal-ctype *satisfies-keywordp-type*)) - (legal-fun-name-p (literal-ctype *fun-name-type*)) - (adjustable-array-p (specifier-type '(and array (not simple-array)))) - (t (let ((type (info :function :predicate-for predicate-name))) - (if type - (specifier-type type) - (%make-hairy-type whole)))))) - -;;;; negation types - -(define-type-method (negation :negate) (x) - (negation-type-type x)) - -(define-type-method (negation :unparse) (x) - (if (type= (negation-type-type x) (specifier-type 'cons)) - 'atom - `(not ,(type-specifier (negation-type-type x))))) - -(define-type-method (negation :simple-subtypep) (type1 type2) - (csubtypep (negation-type-type type2) (negation-type-type type1))) - -(define-type-method (negation :complex-subtypep-arg2) (type1 type2) - (let* ((complement-type2 (negation-type-type type2)) - (intersection2 (type-intersection2 type1 - complement-type2))) - (if intersection2 - ;; FIXME: if uncertain, maybe try arg1? - (type= intersection2 *empty-type*) - (invoke-complex-subtypep-arg1-method type1 type2)))) - -(define-type-method (negation :complex-subtypep-arg1) (type1 type2) - ;; "Incrementally extended heuristic algorithms tend inexorably toward the - ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt - ;; - ;; You may not believe this. I couldn't either. But then I sat down - ;; and drew lots of Venn diagrams. Comments involving a and b refer - ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27. - (block nil - ;; (Several logical truths in this block are true as long as - ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a - ;; case with b=T where we actually reach this type method, but - ;; we'll test for and exclude this case anyway, since future - ;; maintenance might make it possible for it to end up in this - ;; code.) - (multiple-value-bind (equal certain) - (type= type2 *universal-type*) - (unless certain - (return (values nil nil))) - (when equal - (return (values t t)))) - (let ((complement-type1 (negation-type-type type1))) - ;; Do the special cases first, in order to give us a chance if - ;; subtype/supertype relationships are hairy. - (multiple-value-bind (equal certain) - (type= complement-type1 type2) - ;; If a = b, ~a is not a subtype of b (unless b=T, which was - ;; excluded above). - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) - ;; KLUDGE: ANSI requires that the SUBTYPEP result between any - ;; two built-in atomic type specifiers never be uncertain. This - ;; is hard to do cleanly for the built-in types whose - ;; definitions include (NOT FOO), i.e. CONS and RATIO. However, - ;; we can do it with this hack, which uses our global knowledge - ;; that our implementation of the type system uses disjoint - ;; implementation types to represent disjoint sets (except when - ;; types are contained in other types). (This is a KLUDGE - ;; because it's fragile. Various changes in internal - ;; representation in the type system could make it start - ;; confidently returning incorrect results.) -- WHN 2002-03-08 - (unless (or (type-might-contain-other-types-p complement-type1) - (type-might-contain-other-types-p type2)) - ;; Because of the way our types which don't contain other - ;; types are disjoint subsets of the space of possible values, - ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B - ;; is not T, as checked above). - (return (values nil t))) - ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as - ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, - ;; and then the :SIMPLE-SUBTYPEP method would be used instead. - ;; But a CSUBTYPEP relationship might still hold: - (multiple-value-bind (equal certain) - (csubtypep complement-type1 type2) - ;; If a is a subtype of b, ~a is not a subtype of b (unless - ;; b=T, which was excluded above). - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) - (multiple-value-bind (equal certain) - (csubtypep type2 complement-type1) - ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: - ;; That's not true if a=T. Do we know at this point that a is - ;; not T?) - (unless certain - (return (values nil nil))) - (when equal - (return (values nil t)))) - ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? - ;; KLUDGE case above: Other cases here would rely on being able - ;; to catch all possible cases, which the fragility of this type - ;; system doesn't inspire me; for instance, if a is type= to ~b, - ;; then we want T, T; if this is not the case and the types are - ;; disjoint (have an intersection of *empty-type*) then we want - ;; NIL, T; else if the union of a and b is the *universal-type* - ;; then we want T, T. So currently we still claim to be unsure - ;; about e.g. (subtypep '(not fixnum) 'single-float). - ;; - ;; OTOH we might still get here: - (values nil nil)))) - -(define-type-method (negation :complex-=) (type1 type2) - ;; (NOT FOO) isn't equivalent to anything that's not a negation - ;; type, except possibly a type that might contain it in disguise. - (declare (ignore type2)) - (if (type-might-contain-other-types-p type1) - (values nil nil) - (values nil t))) - -(define-type-method (negation :simple-intersection2) (type1 type2) - (let ((not1 (negation-type-type type1)) - (not2 (negation-type-type type2))) - (cond - ((csubtypep not1 not2) type2) - ((csubtypep not2 not1) type1) - ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2 - ;; method, below? The clause would read - ;; - ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*) - ;; - ;; but with proper canonicalization of negation types, there's - ;; no way of constructing two negation types with union of their - ;; negations being the universal type. - (t - (aver (not (eq (type-union not1 not2) *universal-type*))) - nil)))) - -(defun maybe-complex-array-refinement (type1 type2) - (let* ((ntype (negation-type-type type2)) - (ndims (array-type-dimensions ntype)) - (ncomplexp (array-type-complexp ntype)) - (nseltype (array-type-specialized-element-type ntype)) - (neltype (array-type-element-type ntype))) - (if (and (eql ndims '*) (null ncomplexp) - (eq neltype *wild-type*) (eq nseltype *wild-type*)) - (make-array-type (array-type-dimensions type1) - :complexp t - :element-type (array-type-element-type type1) - :specialized-element-type (array-type-specialized-element-type type1))))) - -(define-type-method (negation :complex-intersection2) (type1 type2) - (cond - ((csubtypep type1 (negation-type-type type2)) *empty-type*) - ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) - type1) - ((and (array-type-p type1) (array-type-p (negation-type-type type2))) - (maybe-complex-array-refinement type1 type2)) - (t nil))) - -(define-type-method (negation :simple-union2) (type1 type2) - (let ((not1 (negation-type-type type1)) - (not2 (negation-type-type type2))) - (cond - ((csubtypep not1 not2) type1) - ((csubtypep not2 not1) type2) - ((eq (type-intersection not1 not2) *empty-type*) - *universal-type*) - (t nil)))) - -(define-type-method (negation :complex-union2) (type1 type2) - (cond - ((csubtypep (negation-type-type type2) type1) *universal-type*) - ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) - type2) - (t nil))) - -(define-type-method (negation :simple-=) (type1 type2) - (type= (negation-type-type type1) (negation-type-type type2))) - -(def-type-translator not :list ((:context context) typespec) - ;; "* is not permitted as an argument to the NOT type specifier." - (type-negation (specifier-type typespec context 'not))) - -;;;; numeric types - -(declaim (inline numeric-type-equal)) -(defun numeric-type-equal (type1 type2) - ;; TODO: these 3 can be packed into an integer which makes for just 1 comparison. - ;; (Maybe if 64-bit words use the %BITS slot which has plenty of unused bits) - (and (eq (numeric-type-class type1) (numeric-type-class type2)) - (eq (numeric-type-format type1) (numeric-type-format type2)) - (eq (numeric-type-complexp type1) (numeric-type-complexp type2)))) - -(define-type-method (number :simple-=) (type1 type2) - ;; TODO: construct the hash bits for NUMBER types using a deterministic hash of - ;; the low + high bounds. Then TYPE= can be true only if the hashes are =. - (values - (and (numeric-type-equal type1 type2) - (equalp (numeric-type-low type1) (numeric-type-low type2)) - (equalp (numeric-type-high type1) (numeric-type-high type2))) - t)) - -(define-type-method (number :negate) (type) - (let ((low (numeric-type-low type)) - (high (numeric-type-high type))) - (if (bounds-unbounded-p low high) - (make-negation-type type) - (type-union - (make-negation-type (modified-numeric-type type :low nil :high nil)) - (cond - ((null low) - (modified-numeric-type - type - :low (if (consp high) (car high) (list high)) - :high nil)) - ((null high) - (modified-numeric-type - type - :low nil - :high (if (consp low) (car low) (list low)))) - (t (type-union - (modified-numeric-type - type - :low nil - :high (if (consp low) (car low) (list low))) - (modified-numeric-type - type - :low (if (consp high) (car high) (list high)) - :high nil)))))))) - -(define-type-method (number :unparse) (type) - (let* ((complexp (numeric-type-complexp type)) - (low (numeric-type-low type)) - (high (numeric-type-high type)) - (base (case (numeric-type-class type) - (integer 'integer) - (rational 'rational) - (float (or (numeric-type-format type) 'float)) - (t 'real)))) - (let ((base+bounds - (cond ((and (eq base 'integer) high low) - (let ((high-count (logcount high)) - (high-length (integer-length high))) - (cond ((= low 0) - (cond ((= high 0) '(integer 0 0)) - ((= high 1) 'bit) - ((and (= high-count high-length) - (plusp high-length)) - `(unsigned-byte ,high-length)) - (t - `(mod ,(1+ high))))) - ((and (= low most-negative-fixnum) - (= high most-positive-fixnum)) - 'fixnum) - ((and (= low (lognot high)) - (= high-count high-length) - (> high-count 0)) - `(signed-byte ,(1+ high-length))) - (t - `(integer ,low ,high))))) - (high `(,base ,(or low '*) ,high)) - (low - (if (and (eq base 'integer) (= low 0)) - 'unsigned-byte - `(,base ,low))) - (t base)))) - (ecase complexp - (:real - (aver (neq base 'real)) - base+bounds) - (:complex - (aver (neq base 'real)) - `(complex ,base+bounds)) - ((nil) - (aver (eq base+bounds 'real)) - 'number))))) - -(define-type-method (number :singleton-p) (type) - (let ((low (numeric-type-low type)) - (high (numeric-type-high type))) - (if (and low - (eql low high) - (eql (numeric-type-complexp type) :real) - (member (numeric-type-class type) '(integer rational float))) - (values t (numeric-type-low type)) - (values nil nil)))) - -;;; Return true if X is "less than or equal" to Y, taking open bounds -;;; into consideration. CLOSED is the predicate used to test the bound -;;; on a closed interval (e.g. <=), and OPEN is the predicate used on -;;; open bounds (e.g. <). Y is considered to be the outside bound, in -;;; the sense that if it is infinite (NIL), then the test succeeds, -;;; whereas if X is infinite, then the test fails (unless Y is also -;;; infinite). -;;; -;;; This is for comparing bounds of the same kind, e.g. upper and -;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds. -(defmacro numeric-bound-test (x y closed open) - (setq closed (intern (string closed) "SB-XC") - open (intern (string open) "SB-XC")) - `(cond ((not ,y) t) - ((not ,x) nil) - ((consp ,x) - (if (consp ,y) - (,closed (car ,x) (car ,y)) - (,closed (car ,x) ,y))) - (t - (if (consp ,y) - (,open ,x (car ,y)) - (,closed ,x ,y))))) - -;;; This is used to compare upper and lower bounds. This is different -;;; from the same-bound case: -;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we -;;; return true if *either* arg is NIL. -;;; -- an open inner bound is "greater" and also squeezes the interval, -;;; causing us to use the OPEN test for those cases as well. -(defmacro numeric-bound-test* (x y closed open) - (setq closed (intern (string closed) "SB-XC") - open (intern (string open) "SB-XC")) - `(cond ((not ,y) t) - ((not ,x) t) - ((consp ,x) - (if (consp ,y) - (,open (car ,x) (car ,y)) - (,open (car ,x) ,y))) - (t - (if (consp ,y) - (,open ,x (car ,y)) - (,closed ,x ,y))))) - -;;; Return whichever of the numeric bounds X and Y is "maximal" -;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >). -;;; This is only meaningful for maximizing like bounds, i.e. upper and -;;; upper. If MAX-P is true, then we return NIL if X or Y is NIL, -;;; otherwise we return the other arg. -(defmacro numeric-bound-max (x y closed open max-p) - (setq closed (intern (string closed) "SB-XC") - open (intern (string open) "SB-XC")) - (once-only ((n-x x) - (n-y y)) - `(cond ((not ,n-x) ,(if max-p nil n-y)) - ((not ,n-y) ,(if max-p nil n-x)) - ((consp ,n-x) - (if (consp ,n-y) - (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) - (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) - (t - (if (consp ,n-y) - (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) - (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) - -(define-type-method (number :simple-subtypep) (type1 type2) - (let ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (complexp2 (numeric-type-complexp type2)) - (format2 (numeric-type-format type2)) - (low1 (numeric-type-low type1)) - (high1 (numeric-type-high type1)) - (low2 (numeric-type-low type2)) - (high2 (numeric-type-high type2))) - ;; If one is complex and the other isn't, they are disjoint. - (cond ((not (or (eq (numeric-type-complexp type1) complexp2) - (null complexp2))) - (values nil t)) - ;; If the classes are specified and different, the types are - ;; disjoint unless type2 is RATIONAL and type1 is INTEGER. - ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL - ;; X X) for integral X, but this is dealt with in the - ;; canonicalization inside MAKE-NUMERIC-TYPE ] - ((not (or (eq class1 class2) - (null class2) - (and (eq class1 'integer) (eq class2 'rational)))) - (values nil t)) - ;; If the float formats are specified and different, the types - ;; are disjoint. - ((not (or (eq (numeric-type-format type1) format2) - (null format2))) - (values nil t)) - ;; Check the bounds. - ((and (numeric-bound-test low1 low2 >= >) - (numeric-bound-test high1 high2 <= <)) - (values t t)) - (t - (values nil t))))) - -(!define-superclasses number ((number)) !cold-init-forms) - -;;; If the high bound of LOW is adjacent to the low bound of HIGH, -;;; then return true, otherwise NIL. Adjacency of floating-point intervals -;;; implies that exactly one is an open interval and exactly one is closed -;;; at the adjacency point. -;;; We never (as of now) get here in the cross-compiler with target -;;; floating-point numbers. This seems legitimate as we seldom specify -;;; anything as open intervals. The few cases seem to be the fun-types -;;; of %RANDOM-{SINGLE,DOUBLE}-FLOAT and HASH-TABLE-REHASH-mumble. -(defun numeric-types-adjacent (low high) - (let ((low-bound (numeric-type-high low)) - (high-bound (numeric-type-low high))) - ;; Return T if and only if X is EQL to Y, or X = 0 and -X is EQL to Y. - ;; If both intervals have the same sign of zero at the adjacency point, - ;; then they intersect (as per NUMERIC-TYPES-INTESECT) - ;; so it doesn't matter much what we say here. - (flet ((float-zeros-eqlish (x y) - (or (eql x y) - ;; Calling (EQL (- X) Y) might cons. Using = would be almost the same - ;; but not cons, however I prefer not to assume that the caller has - ;; already checked for matching float formats. EQL enforces that. - ;; Change to use SB-XC:- here if anything requires it. - (and (fp-zero-p x) (fp-zero-p y) (eql (- x) y))))) - (cond ((not (and low-bound high-bound)) nil) - ((and (consp low-bound) (consp high-bound)) nil) - ((consp low-bound) (float-zeros-eqlish (car low-bound) high-bound)) - ((consp high-bound) (float-zeros-eqlish low-bound (car high-bound))) - ((and (eq (numeric-type-class low) 'integer) - (eq (numeric-type-class high) 'integer)) - (eql (1+ low-bound) high-bound)) ; Integer intervals are never open - (t - nil))))) - -;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. -;;; -;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent -;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128), -;;; the compiler does this occasionally during type-derivation to avoid -;;; creating absurdly complex unions of numeric types. -(defvar *approximate-numeric-unions* nil) - -(define-type-method (number :simple-union2) (type1 type2) - (declare (type numeric-type type1 type2)) - (cond ((csubtypep type1 type2) type2) - ((csubtypep type2 type1) type1) - (t - (let ((class1 (numeric-type-class type1)) - (format1 (numeric-type-format type1)) - (complexp1 (numeric-type-complexp type1)) - (class2 (numeric-type-class type2)) - (format2 (numeric-type-format type2)) - (complexp2 (numeric-type-complexp type2))) - (cond - ((and (eq class1 class2) - (eq format1 format2) - (eq complexp1 complexp2) - (or *approximate-numeric-unions* - (numeric-types-intersect type1 type2) - (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class class1 - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))) - ;; FIXME: These two clauses are almost identical, and the - ;; consequents are in fact identical in every respect. - ((and (eq class1 'rational) - (eq class2 'integer) - (eq format1 format2) - (eq complexp1 complexp2) - (integerp (numeric-type-low type2)) - (integerp (numeric-type-high type2)) - (= (numeric-type-low type2) (numeric-type-high type2)) - (or *approximate-numeric-unions* - (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class 'rational - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))) - ((and (eq class1 'integer) - (eq class2 'rational) - (eq format1 format2) - (eq complexp1 complexp2) - (integerp (numeric-type-low type1)) - (integerp (numeric-type-high type1)) - (= (numeric-type-low type1) (numeric-type-high type1)) - (or *approximate-numeric-unions* - (numeric-types-adjacent type1 type2) - (numeric-types-adjacent type2 type1))) - (make-numeric-type - :class 'rational - :format format1 - :complexp complexp1 - :low (numeric-bound-max (numeric-type-low type1) - (numeric-type-low type2) - <= < t) - :high (numeric-bound-max (numeric-type-high type1) - (numeric-type-high type2) - >= > t))) - (t nil)))))) - - -(!cold-init-forms ;; is !PRECOMPUTE-TYPES not doing the right thing? - (setf (info :type :kind 'number) :primitive) - (setf (info :type :builtin 'number) - (make-numeric-type :complexp nil))) - -(def-type-translator complex ((:context context) &optional (typespec '*)) - (if (eq typespec '*) - (specifier-type '(complex real)) - (labels ((not-numeric () - (error "The component type for COMPLEX is not numeric: ~S" - typespec)) - (not-real () - (error "The component type for COMPLEX is not a subtype of REAL: ~S" - typespec)) - (complex1 (component-type) - (unless (numeric-type-p component-type) - (not-numeric)) - (unless (eq (numeric-type-complexp component-type) :real) - (not-real)) - (if (csubtypep component-type (specifier-type '(eql 0))) - *empty-type* - (modified-numeric-type component-type - :complexp :complex))) - (do-complex (ctype) - (cond - ((eq ctype *empty-type*) *empty-type*) - ((eq ctype *universal-type*) (not-real)) - ((typep ctype 'numeric-type) (complex1 ctype)) - ((typep ctype 'union-type) - (%type-union (mapcar #'do-complex (union-type-types ctype)))) - ((typep ctype 'member-type) - (%type-union - (mapcar-member-type-members - (lambda (x) - (if (realp x) - (do-complex (ctype-of x)) - (not-real))) - ctype))) - ((and (typep ctype 'intersection-type) - ;; FIXME: This is very much a - ;; not-quite-worst-effort, but we are required to do - ;; something here because of our representation of - ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must - ;; allow users to ask about (COMPLEX RATIO). This - ;; will of course fail to work right on such types - ;; as (AND INTEGER (SATISFIES ZEROP))... - (let ((numbers (remove-if-not - #'numeric-type-p - (intersection-type-types ctype)))) - (and (car numbers) - (null (cdr numbers)) - (eq (numeric-type-complexp (car numbers)) :real) - (complex1 (car numbers)))))) - (t - (multiple-value-bind (subtypep certainly) - (csubtypep ctype (specifier-type 'real)) - (if (and (not subtypep) certainly) - (not-real) - ;; ANSI just says that TYPESPEC is any subtype of - ;; type REAL, not necessarily a NUMERIC-TYPE. In - ;; particular, at this point TYPESPEC could legally - ;; be a hairy type like (AND NUMBER (SATISFIES - ;; REALP) (SATISFIES ZEROP)), in which case we fall - ;; through the logic above and end up here, - ;; stumped. - ;; FIXME: (COMPLEX NUMBER) is not rejected but should - ;; be, as NUMBER is clearly not a subtype of real. - (bug "~@<(known bug #145): The type ~S is too hairy to be ~ -used for a COMPLEX component.~:@>" - typespec))))))) - (let ((ctype (specifier-type typespec context))) - (do-complex ctype))))) - -;;; If X is *, return NIL, otherwise return the bound, which must be a -;;; member of TYPE or a one-element list of a member of TYPE. -;;; This is not necessarily the canonical bound. An integer bound -;;; should always be an atom, which we'll enforce later if needed. -(defmacro valid-bound (bound type) - `(cond ((eq ,bound '*) nil) - ((sb-xc:typep (if (singleton-p ,bound) (car ,bound) ,bound) ',type) ,bound) - (t - (error ,(format nil "~A bound is not * or ~A ~A or list of one ~:*~A: ~~S" - (string-capitalize bound) - (if (eq type 'integer) "an" "a") - (string-downcase type)) - ,bound)))) - -(def-type-translator integer (&optional (low '*) (high '*)) - (let ((lb (valid-bound low integer)) - (hb (valid-bound high integer))) - (make-numeric-type :class 'integer :complexp :real - :enumerable (not (null (and lb hb))) - :low lb :high hb))) - -(defmacro !def-bounded-type (type class format) - `(def-type-translator ,type (&optional (low '*) (high '*)) - (let ((lb (valid-bound low ,type)) - (hb (valid-bound high ,type))) - (make-numeric-type :class ',class :format ',format - :low lb :high hb)))) - -(!def-bounded-type rational rational nil) - -;;; Unlike CMU CL, we represent the types FLOAT and REAL as -;;; UNION-TYPEs of more primitive types, in order to make -;;; type representation more unique, avoiding problems in the -;;; simplification of things like -;;; (subtypep '(or (single-float -1.0 1.0) (single-float 0.1)) -;;; '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0))) -;;; When we allowed REAL to remain as a separate NUMERIC-TYPE, -;;; it was too easy for the first argument to be simplified to -;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified -;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the -;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because -;;; the first argument can't be seen to be a subtype of any of the -;;; terms in the second argument. -;;; -;;; The old CMU CL way was: -;;; (!def-bounded-type float float nil) -;;; (!def-bounded-type real nil nil) -;;; -;;; FIXME: If this new way works for a while with no weird new -;;; problems, we can go back and rip out support for separate FLOAT -;;; and REAL flavors of NUMERIC-TYPE. The new way was added in -;;; sbcl-0.6.11.22, 2001-03-21. -;;; -;;; FIXME: It's probably necessary to do something to fix the -;;; analogous problem with INTEGER and RATIONAL types. Perhaps -;;; bounded RATIONAL types should be represented as (OR RATIO INTEGER). -(defun coerce-bound (bound type upperp inner-coerce-bound-fun) - (declare (type function inner-coerce-bound-fun)) - (if (eq bound '*) - bound - (funcall inner-coerce-bound-fun bound type upperp))) - -(macrolet ((make-bound (val) - `(let ((coerced ,val)) - (if (listp bound) (list coerced) coerced)))) - -(defun inner-coerce-real-bound (bound type upperp) - (let ((nl most-negative-long-float) - (pl most-positive-long-float)) - (let ((nbound (if (listp bound) (car bound) bound))) - (ecase type - (rational - (make-bound (rational nbound))) - (float - (cond - ((floatp nbound) bound) - (t - ;; Coerce to the widest float format available, to avoid - ;; unnecessary loss of precision, but don't coerce - ;; unrepresentable numbers. - (ecase upperp - ((nil) - (when (sb-xc:< nbound nl) (return-from inner-coerce-real-bound nl))) - ((t) - (when (sb-xc:> nbound pl) (return-from inner-coerce-real-bound pl)))) - (make-bound (coerce nbound 'long-float))))))))) - -(defun inner-coerce-float-bound (bound type upperp) - (let ((nd most-negative-double-float) - (pd most-positive-double-float) - (ns most-negative-single-float) - (ps most-positive-single-float)) - (let ((nbound (if (listp bound) (car bound) bound))) - (ecase type - (single-float - (cond - ((cl:typep nbound 'single-float) bound) - (t - (ecase upperp - ((nil) - (when (sb-xc:< nbound ns) (return-from inner-coerce-float-bound ns))) - ((t) - (when (sb-xc:> nbound ps) (return-from inner-coerce-float-bound ps)))) - (make-bound (coerce nbound 'single-float))))) - (double-float - (cond - ((cl:typep nbound 'double-float) bound) - (t - (ecase upperp - ((nil) - (when (sb-xc:< nbound nd) (return-from inner-coerce-float-bound nd))) - ((t) - (when (sb-xc:> nbound pd) (return-from inner-coerce-float-bound pd)))) - (make-bound (coerce nbound 'double-float))))))))) -) ; end MACROLET - -(defun coerced-real-bound (bound type upperp) - (coerce-bound bound type upperp #'inner-coerce-real-bound)) -(defun coerced-float-bound (bound type upperp) - (coerce-bound bound type upperp #'inner-coerce-float-bound)) -(def-type-translator real (&optional (low '*) (high '*)) - (specifier-type `(or (float ,(coerced-real-bound low 'float nil) - ,(coerced-real-bound high 'float t)) - (rational ,(coerced-real-bound low 'rational nil) - ,(coerced-real-bound high 'rational t))))) -(def-type-translator float (&optional (low '*) (high '*)) - (specifier-type - `(or (single-float ,(coerced-float-bound low 'single-float nil) - ,(coerced-float-bound high 'single-float t)) - (double-float ,(coerced-float-bound low 'double-float nil) - ,(coerced-float-bound high 'double-float t)) - #+long-float ,(error "stub: no long float support yet")))) - -(macrolet ((define-float-format (f) `(!def-bounded-type ,f float ,f))) - (define-float-format single-float) - (define-float-format double-float)) - -(defun numeric-types-intersect (type1 type2) - (declare (type numeric-type type1 type2)) - (let* ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (complexp1 (numeric-type-complexp type1)) - (complexp2 (numeric-type-complexp type2)) - (format1 (numeric-type-format type1)) - (format2 (numeric-type-format type2)) - (low1 (numeric-type-low type1)) - (high1 (numeric-type-high type1)) - (low2 (numeric-type-low type2)) - (high2 (numeric-type-high type2))) - ;; If one is complex and the other isn't, then they are disjoint. - (cond ((not (or (eq complexp1 complexp2) - (null complexp1) (null complexp2))) - nil) - ;; If either type is a float, then the other must either be - ;; specified to be a float or unspecified. Otherwise, they - ;; are disjoint. - ((and (eq class1 'float) - (not (member class2 '(float nil)))) nil) - ((and (eq class2 'float) - (not (member class1 '(float nil)))) nil) - ;; If the float formats are specified and different, the - ;; types are disjoint. - ((not (or (eq format1 format2) (null format1) (null format2))) - nil) - (t - ;; Check the bounds. This is a bit odd because we must - ;; always have the outer bound of the interval as the - ;; second arg. - (if (numeric-bound-test high1 high2 <= <) - (or (and (numeric-bound-test low1 low2 >= >) - (numeric-bound-test* low1 high2 <= <)) - (and (numeric-bound-test low2 low1 >= >) - (numeric-bound-test* low2 high1 <= <))) - (or (and (numeric-bound-test* low2 high1 <= <) - (numeric-bound-test low2 low1 >= >)) - (and (numeric-bound-test high2 high1 <= <) - (numeric-bound-test* high2 low1 >= >)))))))) - -;;; Take the numeric bound X and convert it into something that can be -;;; used as a bound in a numeric type with the specified CLASS and -;;; FORMAT. If UP-P is true, then we round up as needed, otherwise we -;;; round down. UP-P true implies that X is a lower bound, i.e. (N) > N. -;;; -;;; This is used by NUMERIC-TYPE-INTERSECTION to mash the bound into -;;; the appropriate type number. X may only be a float when CLASS is -;;; FLOAT. -;;; -;;; ### Note: it is possible for the coercion to a float to overflow -;;; or underflow. This happens when the bound doesn't fit in the -;;; specified format. In this case, we should really return the -;;; appropriate {Most | Least}-{Positive | Negative}-XXX-Float float -;;; of desired format. But these conditions aren't currently signalled -;;; in any useful way. -;;; -;;; Also, when converting an open rational bound into a float we -;;; should probably convert it to a closed bound of the closest float -;;; in the specified format. KLUDGE: In general, open float bounds are -;;; screwed up. -- (comment from original CMU CL) -(defun round-numeric-bound (x class format up-p) - (if x - (let ((cx (if (consp x) (car x) x))) - (ecase class - ((nil rational) x) - (integer - (if (and (consp x) (integerp cx)) - (if up-p (1+ cx) (1- cx)) - (if up-p (ceiling cx) (floor cx)))) - (float - (aver format) - (let ((res - (cond - ((and format (subtypep format 'double-float)) - (if (sb-xc:<= most-negative-double-float cx most-positive-double-float) - (coerce cx format) - nil)) - (t - (if (sb-xc:<= most-negative-single-float cx most-positive-single-float) - ;; FIXME: bug #389 - (coerce cx (or format 'single-float)) - nil))))) - (if (and (consp x) res) - (list res) - res))))) - nil)) - -;;; Handle the case of type intersection on two numeric types. We use -;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no -;;; intersection. If an attribute in TYPE1 is unspecified, then we use -;;; TYPE2's attribute, which must be at least as restrictive. If the -;;; types intersect, then the only attributes that can be specified -;;; and different are the class and the bounds. -;;; -;;; When the class differs, we use the more restrictive class. The -;;; only interesting case is RATIONAL/INTEGER, since RATIONAL includes -;;; INTEGER. -;;; -;;; We make the result lower (upper) bound the maximum (minimum) of -;;; the argument lower (upper) bounds. We convert the bounds into the -;;; appropriate numeric type before maximizing. This avoids possible -;;; confusion due to mixed-type comparisons (but I think the result is -;;; the same). -(define-type-method (number :simple-intersection2) (type1 type2) - (declare (type numeric-type type1 type2)) - (if (numeric-types-intersect type1 type2) - (let* ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (class (ecase class1 - ((nil) class2) - ((integer float) class1) - (rational (if (eq class2 'integer) - 'integer - 'rational)))) - (format (or (numeric-type-format type1) - (numeric-type-format type2)))) - (make-numeric-type - :class class - :format format - :complexp (or (numeric-type-complexp type1) - (numeric-type-complexp type2)) - :low (numeric-bound-max - (round-numeric-bound (numeric-type-low type1) - class format t) - (round-numeric-bound (numeric-type-low type2) - class format t) - > >= nil) - :high (numeric-bound-max - (round-numeric-bound (numeric-type-high type1) - class format nil) - (round-numeric-bound (numeric-type-high type2) - class format nil) - < <= nil))) - *empty-type*)) - -;;; Given two float formats, return the one with more precision. If -;;; either one is null, return NIL. -(defun float-format-max (f1 f2) - (when (and f1 f2) - (dolist (f *float-formats* (error "bad float format: ~S" f1)) - (when (or (eq f f1) (eq f f2)) - (return f))))) - -;;; Return the result of an operation on TYPE1 and TYPE2 according to -;;; the rules of numeric contagion. This is always NUMBER, some float -;;; format (possibly complex) or RATIONAL. Due to rational -;;; canonicalization, there isn't much we can do here with integers or -;;; rational complex numbers. -;;; -;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This -;;; is useful mainly for allowing types that are technically numbers, -;;; but not a NUMERIC-TYPE. -(defun numeric-contagion (type1 type2) - (if (and (numeric-type-p type1) (numeric-type-p type2)) - (let ((class1 (numeric-type-class type1)) - (class2 (numeric-type-class type2)) - (format1 (numeric-type-format type1)) - (format2 (numeric-type-format type2)) - (complexp1 (numeric-type-complexp type1)) - (complexp2 (numeric-type-complexp type2))) - (cond ((or (null complexp1) - (null complexp2)) - (specifier-type 'number)) - ((eq class1 'float) - (make-numeric-type - :class 'float - :format (ecase class2 - (float (float-format-max format1 format2)) - ((integer rational) format1) - ((nil) - ;; A double-float with any real number is a - ;; double-float. - #-long-float - (if (eq format1 'double-float) - 'double-float - nil) - ;; A long-float with any real number is a - ;; long-float. - #+long-float - (if (eq format1 'long-float) - 'long-float - nil))) - :complexp (if (or (eq complexp1 :complex) - (eq complexp2 :complex)) - :complex - :real))) - ((eq class2 'float) (numeric-contagion type2 type1)) - ((and (eq complexp1 :real) (eq complexp2 :real)) - (make-numeric-type - :class (and class1 class2 'rational) - :complexp :real)) - (t - (specifier-type 'number)))) - (specifier-type 'number))) - -;;;; array types - -(define-type-method (array :simple-=) (type1 type2) - (cond ((not (and (equal (array-type-dimensions type1) - (array-type-dimensions type2)) - (eq (array-type-complexp type1) - (array-type-complexp type2)))) - (values nil t)) - ((or (unknown-type-p (array-type-element-type type1)) - (unknown-type-p (array-type-element-type type2))) - (type= (array-type-element-type type1) - (array-type-element-type type2))) - (t - (values (type= (array-type-specialized-element-type type1) - (array-type-specialized-element-type type2)) - t)))) - -(define-type-method (array :negate) (type) - ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the - ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY - ;; NIL) (ARRAY CHAR) ...) equivalent?" -- CSR, 2003-12-10 - ;; A symptom of the aforementioned is that the following are not TYPE= - ;; (AND (VECTOR T) (NOT SIMPLE-ARRAY)) ; an ARRAY-TYPE - ;; (AND (VECTOR T) (NOT SIMPLE-VECTOR)) ; an INTERSECTION-TYPE - ;; even though (VECTOR T) makes it so that the (NOT) clause in each can - ;; only provide one additional bit of information: that the vector - ;; is complex as opposed to simple. The rank and element-type are fixed. - (if (and (eq (array-type-dimensions type) '*) - (eq (array-type-complexp type) 't) - (eq (array-type-element-type type) *wild-type*)) - ;; (NOT ) = either SIMPLE-ARRAY or (NOT ARRAY). - ;; This is deliberately asymmetric - trying to say that NOT simple-array - ;; equals hairy-array leads to infinite recursion. - (type-union (make-array-type '* :complexp nil - :element-type *wild-type*) - (make-negation-type - (make-array-type '* :element-type *wild-type*))) - (make-negation-type type))) - -(define-type-method (array :unparse) (type) - (let* ((dims (array-type-dimensions type)) - ;; Compare the specialised element type and the - ;; derived element type. If the derived type - ;; is so small that it jumps to a smaller upgraded - ;; element type, use the specialised element type. - ;; - ;; This protects from unparsing - ;; (and (vector (or bit symbol)) - ;; (vector (or bit character))) - ;; i.e., the intersection of two T array types, - ;; as a bit vector. - (stype (array-type-specialized-element-type type)) - (dtype (array-type-element-type type)) - (utype (%upgraded-array-element-type dtype)) - (eltype (type-specifier (if (type= stype utype) - dtype - stype))) - (complexp (array-type-complexp type))) - (cond ((eq dims '*) - (if (eq eltype '*) - (ecase complexp - ((t) '(and array (not simple-array))) - ((:maybe) 'array) - ((nil) 'simple-array)) - (ecase complexp - ((t) `(and (array ,eltype) (not simple-array))) - ((:maybe) `(array ,eltype)) - ((nil) `(simple-array ,eltype))))) - ((= (length dims) 1) - (if complexp - (let ((answer - (if (eq (car dims) '*) - (case eltype - (bit 'bit-vector) - ((base-char #-sb-unicode character) 'base-string) - (* 'vector) - (t `(vector ,eltype))) - (case eltype - (bit `(bit-vector ,(car dims))) - ((base-char #-sb-unicode character) - `(base-string ,(car dims))) - (t `(vector ,eltype ,(car dims))))))) - (if (eql complexp :maybe) - answer - `(and ,answer (not simple-array)))) - (if (eq (car dims) '*) - (case eltype - (bit 'simple-bit-vector) - ((base-char #-sb-unicode character) 'simple-base-string) - ((t) 'simple-vector) - (t `(simple-array ,eltype (*)))) - (case eltype - (bit `(simple-bit-vector ,(car dims))) - ((base-char #-sb-unicode character) - `(simple-base-string ,(car dims))) - ((t) `(simple-vector ,(car dims))) - (t `(simple-array ,eltype ,dims)))))) - (t - (ecase complexp - ((t) `(and (array ,eltype ,dims) (not simple-array))) - ((:maybe) `(array ,eltype ,dims)) - ((nil) `(simple-array ,eltype ,dims))))))) - -(define-type-method (array :simple-subtypep) (type1 type2) - (let ((dims1 (array-type-dimensions type1)) - (dims2 (array-type-dimensions type2)) - (complexp2 (array-type-complexp type2))) - (cond (;; not subtypep unless dimensions are compatible - (not (or (eq dims2 '*) - (and (not (eq dims1 '*)) - ;; (sbcl-0.6.4 has trouble figuring out that - ;; DIMS1 and DIMS2 must be lists at this - ;; point, and knowing that is important to - ;; compiling EVERY efficiently.) - (= (length (the list dims1)) - (length (the list dims2))) - (every (lambda (x y) - (or (eq y '*) (eql x y))) - (the list dims1) - (the list dims2))))) - (values nil t)) - ;; not subtypep unless complexness is compatible - ((not (or (eq complexp2 :maybe) - (eq (array-type-complexp type1) complexp2))) - (values nil t)) - ;; Since we didn't fail any of the tests above, we win - ;; if the TYPE2 element type is wild. - ((eq (array-type-element-type type2) *wild-type*) - (values t t)) - (;; Since we didn't match any of the special cases above, if - ;; either element type is unknown we can only give a good - ;; answer if they are the same. - (or (unknown-type-p (array-type-element-type type1)) - (unknown-type-p (array-type-element-type type2))) - (if (type= (array-type-element-type type1) - (array-type-element-type type2)) - (values t t) - (values nil nil))) - (;; Otherwise, the subtype relationship holds iff the - ;; types are equal, and they're equal iff the specialized - ;; element types are identical. - t - (values (type= (array-type-specialized-element-type type1) - (array-type-specialized-element-type type2)) - t))))) - -(!define-superclasses array ((vector vector) (array)) !cold-init-forms) - -(defun array-types-intersect (type1 type2) - (declare (type array-type type1 type2)) - (let ((dims1 (array-type-dimensions type1)) - (dims2 (array-type-dimensions type2)) - (complexp1 (array-type-complexp type1)) - (complexp2 (array-type-complexp type2))) - ;; See whether dimensions are compatible. - (cond ((not (or (eq dims1 '*) (eq dims2 '*) - (and (= (length dims1) (length dims2)) - (every (lambda (x y) - (or (eq x '*) (eq y '*) (= x y))) - dims1 dims2)))) - (values nil t)) - ;; See whether complexpness is compatible. - ((not (or (eq complexp1 :maybe) - (eq complexp2 :maybe) - (eq complexp1 complexp2))) - (values nil t)) - ;; Old comment: - ;; - ;; If either element type is wild, then they intersect. - ;; Otherwise, the types must be identical. - ;; - ;; FIXME: There seems to have been a fair amount of - ;; confusion about the distinction between requested element - ;; type and specialized element type; here is one of - ;; them. If we request an array to hold objects of an - ;; unknown type, we can do no better than represent that - ;; type as an array specialized on wild-type. We keep the - ;; requested element-type in the -ELEMENT-TYPE slot, and - ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here, - ;; we must test for the SPECIALIZED slot being *WILD-TYPE*, - ;; not just the ELEMENT-TYPE slot. Maybe the return value - ;; in that specific case should be T, NIL? Or maybe this - ;; function should really be called - ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this - ;; was responsible for bug #123, and this whole issue could - ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21 - ((or (eq (array-type-specialized-element-type type1) *wild-type*) - (eq (array-type-specialized-element-type type2) *wild-type*) - (type= (array-type-specialized-element-type type1) - (array-type-specialized-element-type type2))) - - (values t t)) - (t - (values nil t))))) - -(defun unite-array-types-complexp (type1 type2) - (let ((complexp1 (array-type-complexp type1)) - (complexp2 (array-type-complexp type2))) - (cond - ((eq complexp1 complexp2) - ;; both types are the same complexp-ity - (values complexp1 t)) - ((eq complexp1 :maybe) - ;; type1 is wild-complexp - (values :maybe type1)) - ((eq complexp2 :maybe) - ;; type2 is wild-complexp - (values :maybe type2)) - (t - ;; both types partition the complexp-space - (values :maybe nil))))) - -(defun unite-array-types-dimensions (type1 type2) - (let ((dims1 (array-type-dimensions type1)) - (dims2 (array-type-dimensions type2))) - (cond ((equal dims1 dims2) - ;; both types are same dimensionality - (values dims1 t)) - ((eq dims1 '*) - ;; type1 is wild-dimensions - (values '* type1)) - ((eq dims2 '*) - ;; type2 is wild-dimensions - (values '* type2)) - ((not (= (length dims1) (length dims2))) - ;; types have different number of dimensions - (values :incompatible nil)) - (t - ;; we need to check on a per-dimension basis - (let* ((supertype1 t) - (supertype2 t) - (compatible t) - (result (mapcar (lambda (dim1 dim2) - (cond - ((equal dim1 dim2) - dim1) - ((eq dim1 '*) - (setf supertype2 nil) - '*) - ((eq dim2 '*) - (setf supertype1 nil) - '*) - (t - (setf compatible nil)))) - dims1 dims2))) - (cond - ((or (not compatible) - (and (not supertype1) - (not supertype2))) - (values :incompatible nil)) - ((and supertype1 supertype2) - (values result supertype1)) - (t - (values result (if supertype1 type1 type2))))))))) - -(defun unite-array-types-element-types (type1 type2) - ;; FIXME: We'd love to be able to unite the full set of specialized - ;; array element types up to *wild-type*, but :simple-union2 is - ;; performed pairwise, so we don't have a good hook for it and our - ;; representation doesn't allow us to easily detect the situation - ;; anyway. - ;; But see SIMPLIFY-ARRAY-UNIONS which is able to do something like that. - (let* ((eltype1 (array-type-element-type type1)) - (eltype2 (array-type-element-type type2)) - (stype1 (array-type-specialized-element-type type1)) - (stype2 (array-type-specialized-element-type type2)) - (wild1 (eq eltype1 *wild-type*)) - (wild2 (eq eltype2 *wild-type*))) - (cond - ((type= eltype1 eltype2) - (values eltype1 stype1 t)) - (wild1 - (values eltype1 stype1 type1)) - (wild2 - (values eltype2 stype2 type2)) - ((not (type= stype1 stype2)) - ;; non-wild types that don't share UAET don't unite - (values :incompatible nil nil)) - ((csubtypep eltype1 eltype2) - (values eltype2 stype2 type2)) - ((csubtypep eltype2 eltype1) - (values eltype1 stype1 type1)) - (t - (values :incompatible nil nil))))) - -(defun unite-array-types-supertypes-compatible-p (&rest supertypes) - ;; supertypes are compatible if they are all T, if there is a single - ;; NIL and all the rest are T, or if all non-T supertypes are the - ;; same and not NIL. - (let ((interesting-supertypes - (remove t supertypes))) - (or (not interesting-supertypes) - (equal interesting-supertypes '(nil)) - ;; supertypes are (OR BOOLEAN ARRAY-TYPE), so... - (typep (remove-duplicates interesting-supertypes) - '(cons array-type null))))) - -(define-type-method (array :simple-union2) (type1 type2) - (multiple-value-bind - (result-eltype result-stype eltype-supertype) - (unite-array-types-element-types type1 type2) - (multiple-value-bind - (result-complexp complexp-supertype) - (unite-array-types-complexp type1 type2) - (multiple-value-bind - (result-dimensions dimensions-supertype) - (unite-array-types-dimensions type1 type2) - (when (and (not (eq result-dimensions :incompatible)) - (not (eq result-eltype :incompatible)) - (unite-array-types-supertypes-compatible-p - eltype-supertype complexp-supertype dimensions-supertype)) - (make-array-type result-dimensions - :complexp result-complexp - :element-type result-eltype - :specialized-element-type result-stype)))))) - -(define-type-method (array :simple-intersection2) (type1 type2) - (declare (type array-type type1 type2)) - (if (array-types-intersect type1 type2) - (let ((dims1 (array-type-dimensions type1)) - (dims2 (array-type-dimensions type2)) - (complexp1 (array-type-complexp type1)) - (complexp2 (array-type-complexp type2)) - (eltype1 (array-type-element-type type1)) - (eltype2 (array-type-element-type type2)) - (stype1 (array-type-specialized-element-type type1)) - (stype2 (array-type-specialized-element-type type2))) - (make-array-type (cond ((eq dims1 '*) dims2) - ((eq dims2 '*) dims1) - (t - (mapcar (lambda (x y) (if (eq x '*) y x)) - dims1 dims2))) - :complexp (if (eq complexp1 :maybe) complexp2 complexp1) - :element-type (cond - ((eq eltype1 *wild-type*) eltype2) - ((eq eltype2 *wild-type*) eltype1) - (t (type-intersection eltype1 eltype2))) - :specialized-element-type (cond - ((eq stype1 *wild-type*) stype2) - ((eq stype2 *wild-type*) stype1) - (t - (aver (type= stype1 stype2)) - stype1)))) - *empty-type*)) - -;;; Check a supplied dimension list to determine whether it is legal, -;;; and return it in canonical form (as either '* or a list). -(defun canonical-array-dimensions (dims) - (typecase dims - ((member *) dims) - (integer - (when (minusp dims) - (error "Arrays can't have a negative number of dimensions: ~S" dims)) - (when (>= dims array-rank-limit) - (error "array type with too many dimensions: ~S" dims)) - (make-list dims :initial-element '*)) - (list - (when (>= (length dims) array-rank-limit) - (error "array type with too many dimensions: ~S" dims)) - (dolist (dim dims) - (unless (eq dim '*) - (unless (and (integerp dim) - (>= dim 0) - (< dim array-dimension-limit)) - (error "bad dimension in array type: ~S" dim)))) - dims) - (t - (error "Array dimensions is not a list, integer or *:~% ~S" dims)))) - -;;;; MEMBER types - -(define-type-method (member :negate) (type) - (let ((xset (member-type-xset type)) - (fp-zeroes (member-type-fp-zeroes type))) - (if fp-zeroes - ;; Hairy case, which needs to do a bit of float type - ;; canonicalization. - (apply #'type-intersection - (if (xset-empty-p xset) - *universal-type* - (make-negation-type (make-member-type xset nil))) - (mapcar - (lambda (x) - (let* ((opposite (sb-xc:- x)) - (type (ctype-of opposite))) - (type-union - (make-negation-type - (modified-numeric-type type :low nil :high nil)) - (modified-numeric-type type :low nil :high (list opposite)) - (make-eql-type opposite) - (modified-numeric-type type :low (list opposite) :high nil)))) - fp-zeroes)) - ;; Easy case - (make-negation-type type)))) - -(define-type-method (member :unparse) (type) - (cond ((eq type (specifier-type 'null)) 'null) ; NULL type is EQ-comparable - ((eq type (specifier-type 'boolean)) 'boolean) ; so is BOOLEAN - (t `(member ,@(member-type-members type))))) - -(define-type-method (member :singleton-p) (type) - (if (eql 1 (member-type-size type)) - (values t (first (member-type-members type))) - (values nil nil))) - -(define-type-method (member :simple-subtypep) (type1 type2) - (values (and (xset-subset-p (member-type-xset type1) - (member-type-xset type2)) - (subsetp (member-type-fp-zeroes type1) - (member-type-fp-zeroes type2))) - t)) - -(define-type-method (member :complex-subtypep-arg1) (type1 type2) - (block punt - (mapc-member-type-members - (lambda (elt) - (multiple-value-bind (ok surep) (ctypep elt type2) - (unless surep - (return-from punt (values nil nil))) - (unless ok - (return-from punt (values nil t))))) - type1) - (values t t))) - -;;; We punt if the odd type is enumerable and intersects with the -;;; MEMBER type. If not enumerable, then it is definitely not a -;;; subtype of the MEMBER type. -(define-type-method (member :complex-subtypep-arg2) (type1 type2) - (cond ((not (type-enumerable type1)) (values nil t)) - ((types-equal-or-intersect type1 type2) - (invoke-complex-subtypep-arg1-method type1 type2)) - (t (values nil t)))) - -(define-type-method (member :simple-intersection2) (type1 type2) - (make-member-type (xset-intersection (member-type-xset type1) - (member-type-xset type2)) - (intersection (member-type-fp-zeroes type1) - (member-type-fp-zeroes type2)))) - -(define-type-method (member :complex-intersection2) (type1 type2) - (block punt - (let ((xset (alloc-xset)) - (fp-zeroes nil)) - (mapc-member-type-members - (lambda (member) - (multiple-value-bind (ok sure) (ctypep member type1) - (unless sure - (return-from punt nil)) - (when ok - (if (fp-zero-p member) - (pushnew member fp-zeroes) - (add-to-xset member xset))))) - type2) - (if (and (xset-empty-p xset) (not fp-zeroes)) - *empty-type* - (make-member-type xset fp-zeroes))))) - -;;; We don't need a :COMPLEX-UNION2, since the only interesting case is -;;; a union type, and the member/union interaction is handled by the -;;; union type method. -(define-type-method (member :simple-union2) (type1 type2) - (make-member-type (xset-union (member-type-xset type1) - (member-type-xset type2)) - (union (member-type-fp-zeroes type1) - (member-type-fp-zeroes type2)))) - -(define-type-method (member :simple-=) (type1 type2) - (let ((xset1 (member-type-xset type1)) - (xset2 (member-type-xset type2)) - (l1 (member-type-fp-zeroes type1)) - (l2 (member-type-fp-zeroes type2))) - (values (and (eql (xset-count xset1) (xset-count xset2)) - (xset-subset-p xset1 xset2) - (xset-subset-p xset2 xset1) - (subsetp l1 l2) - (subsetp l2 l1)) - t))) - -(define-type-method (member :complex-=) (type1 type2) - (if (type-enumerable type1) - (multiple-value-bind (val win) (csubtypep type2 type1) - (if (or val (not win)) - (values nil nil) - (values nil t))) - (values nil t))) - -(def-type-translator member :list (&rest members) - ;; "* may appear as an argument to a MEMBER type specifier, but it indicates the - ;; literal symbol *, and does not represent an unspecified value." - (if members - (let (ms numbers char-codes) - (dolist (m (remove-duplicates members)) - (typecase m - (character (push (sb-xc:char-code m) char-codes)) - (real (if (and (floatp m) (zerop m)) - (push m ms) - (push (ctype-of m) numbers))) - (t (push m ms)))) - (apply #'type-union - (member-type-from-list ms) - (make-character-set-type (mapcar (lambda (x) (cons x x)) - (sort char-codes #'<))) - (nreverse numbers))) - *empty-type*)) - -;;;; intersection types -;;;; -;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach -;;;; of punting on all AND types, not just the unreasonably complicated -;;;; ones. The change was motivated by trying to get the KEYWORD type -;;;; to behave sensibly: -;;;; ;; reasonable definition -;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP))) -;;;; ;; reasonable behavior -;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL)) -;;;; Without understanding a little about the semantics of AND, we'd -;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely -;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's -;;;; not so good..) -;;;; -;;;; We still follow the example of CMU CL to some extent, by punting -;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types -;;;; involving AND. - -(define-type-class intersection - :enumerable #'compound-type-enumerable - :might-contain-other-types t) - -(define-type-method (intersection :negate) (type) - (%type-union - (mapcar #'type-negation (intersection-type-types type)))) - -;;; A few intersection types have special names. The others just get -;;; mechanically unparsed. -(define-type-method (intersection :unparse) (type) - (declare (type ctype type)) - ;; If perhaps the magic intersection types were interned, then - ;; we could compare by EQ here instead of parsing in order to unparse. - (or (find type '(ratio keyword compiled-function) :key #'specifier-type :test #'type=) - `(and ,@(mapcar #'type-specifier (intersection-type-types type))))) - -(define-type-method (intersection :singleton-p) (type) - (loop for constituent in (intersection-type-types type) - do - (multiple-value-bind (single value) (type-singleton-p constituent) - (when single - (return (values single value)))) - finally (return (values nil nil)))) - -;;; shared machinery for type equality: true if every type in the set -;;; TYPES1 matches a type in the set TYPES2 and vice versa -(defun type=-set (types1 types2) - (flet ((type<=-set (x y) - (declare (type list x y)) - (every/type (lambda (x y-element) - (any/type #'type= y-element x)) - x y))) - (and/type (type<=-set types1 types2) - (type<=-set types2 types1)))) - -;;; Two intersection types are equal if their subtypes are equal sets. -;;; -;;; FIXME: Might it be better to use -;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X)) -;;; instead, since SUBTYPEP is the usual relationship that we care -;;; most about, so it would be good to leverage any ingenuity there -;;; in this more obscure method? -(define-type-method (intersection :simple-=) (type1 type2) - (type=-set (intersection-type-types type1) - (intersection-type-types type2))) - -(defun %intersection-complex-subtypep-arg1 (type1 type2) - (type= type1 (type-intersection type1 type2))) - -(defun %intersection-simple-subtypep (type1 type2) - (every/type #'%intersection-complex-subtypep-arg1 - type1 - (intersection-type-types type2))) - -(define-type-method (intersection :simple-subtypep) (type1 type2) - (%intersection-simple-subtypep type1 type2)) - -(define-type-method (intersection :complex-subtypep-arg1) (type1 type2) - (%intersection-complex-subtypep-arg1 type1 type2)) - -(defun %intersection-complex-subtypep-arg2 (type1 type2) - (every/type #'csubtypep type1 (intersection-type-types type2))) - -(define-type-method (intersection :complex-subtypep-arg2) (type1 type2) - (%intersection-complex-subtypep-arg2 type1 type2)) - -;;; FIXME: This will look eeriely familiar to readers of the UNION -;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's -;;; because it was generated by cut'n'paste methods. Given that -;;; intersections and unions have all sorts of symmetries known to -;;; mathematics, it shouldn't be beyond the ken of some programmers to -;;; reflect those symmetries in code in a way that ties them together -;;; more strongly than having two independent near-copies :-/ -(define-type-method (intersection :simple-union2 :complex-union2) - (type1 type2) - ;; Within this method, type2 is guaranteed to be an intersection - ;; type: - (aver (intersection-type-p type2)) - ;; Make sure to call only the applicable methods... - (cond ((and (intersection-type-p type1) - (%intersection-simple-subtypep type1 type2)) type2) - ((and (intersection-type-p type1) - (%intersection-simple-subtypep type2 type1)) type1) - ((and (not (intersection-type-p type1)) - (%intersection-complex-subtypep-arg2 type1 type2)) - type2) - ((and (not (intersection-type-p type1)) - (%intersection-complex-subtypep-arg1 type2 type1)) - type1) - ;; KLUDGE: This special (and somewhat hairy) magic is required - ;; to deal with the RATIONAL/INTEGER special case. The UNION - ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER)) - ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28 - ((and (csubtypep type2 (specifier-type 'ratio)) - (numeric-type-p type1) - (csubtypep type1 (specifier-type 'integer)) - (csubtypep type2 - (make-numeric-type - :class 'rational - :complexp nil - :low (if (null (numeric-type-low type1)) - nil - (list (1- (numeric-type-low type1)))) - :high (if (null (numeric-type-high type1)) - nil - (list (1+ (numeric-type-high type1))))))) - (let* ((intersected (intersection-type-types type2)) - (remaining (remove (specifier-type '(not integer)) - intersected - :test #'type=))) - (and (not (equal intersected remaining)) - (type-union type1 (%type-intersection remaining))))) - (t - (let ((accumulator *universal-type*)) - (do ((t2s (intersection-type-types type2) (cdr t2s))) - ((null t2s) accumulator) - (let ((union (type-union type1 (car t2s)))) - (when (union-type-p union) - ;; we have to give up here -- there are all sorts of - ;; ordering worries, but it's better than before. - ;; Doing exactly the same as in the UNION - ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack - ;; overflow with the mutual recursion never bottoming - ;; out. - (if (and (eq accumulator *universal-type*) - (null (cdr t2s))) - ;; KLUDGE: if we get here, we have a partially - ;; simplified result. While this isn't by any - ;; means a universal simplification, including - ;; this logic here means that we can get (OR - ;; KEYWORD (NOT KEYWORD)) canonicalized to T. - (return union) - (return nil))) - (setf accumulator - (type-intersection accumulator union)))))))) - -(def-type-translator and :list ((:context context) &rest type-specifiers) - ;; "* is not permitted as an argument to the AND type specifier." - (%type-intersection (mapcar (lambda (x) (specifier-type x context 'and)) - type-specifiers))) - -;;;; union types - -(define-type-class union - :enumerable #'compound-type-enumerable - :might-contain-other-types t) - -(define-type-method (union :negate) (type) - (declare (type ctype type)) - (%type-intersection (mapcar #'type-negation (union-type-types type)))) - -;;; Unlike ARRAY-TYPE-DIMENSIONS this handles union types, which -;;; includes the type STRING. -(defun ctype-array-dimensions (type) - (labels ((process-compound-type (types) - (let (dimensions) - (dolist (type types) - (unless (or (hairy-type-p type) - (negation-type-p type)) - (let ((current-dimensions (determine type))) - (cond ((eq current-dimensions '*) - (return-from ctype-array-dimensions '*)) - ((and dimensions - (not (equal current-dimensions dimensions))) - (if (= (length dimensions) - (length current-dimensions)) - (setf dimensions - (loop for dimension in dimensions - for current-dimension in current-dimensions - collect (if (eql dimension current-dimension) - dimension - '*))) - (return-from ctype-array-dimensions '*))) - (t - - (setf dimensions current-dimensions)))))) - dimensions)) - (determine (type) - (etypecase type - (array-type - (array-type-dimensions type)) - (union-type - (process-compound-type (union-type-types type))) - (member-type - (process-compound-type - (mapcar #'ctype-of (member-type-members type)))) - (intersection-type - (process-compound-type (intersection-type-types type)))))) - (determine type))) - -(defun ctype-array-specialized-element-types (type) - (let (types) - (labels ((process-compound-type (types) - (loop for type in types - unless (or (hairy-type-p type) - (negation-type-p type)) - do (determine type))) - (determine (type) - (etypecase type - (array-type - (when (eq (array-type-specialized-element-type type) *wild-type*) - (return-from ctype-array-specialized-element-types - *wild-type*)) - (pushnew (array-type-specialized-element-type type) - types :test #'type=)) - (union-type - (process-compound-type (union-type-types type))) - (intersection-type - (process-compound-type (intersection-type-types type))) - (member-type - (process-compound-type - (mapcar #'ctype-of (member-type-members type))))))) - (determine type)) - types)) - -(defun unparse-string-type (ctype string-type) - (let ((string-ctype (specifier-type string-type))) - (and (union-type-p ctype) - (csubtypep ctype string-ctype) - (let ((types (copy-list (union-type-types string-ctype)))) - (and (loop for type in (union-type-types ctype) - for matching = (and (array-type-p type) - (neq (array-type-complexp type) t) - (find type types - :test #'csubtypep)) - always matching - do (setf types (delete matching types))) - (null types))) - (let ((dimensions (ctype-array-dimensions ctype))) - (cond ((and (singleton-p dimensions) - (integerp (car dimensions))) - `(,string-type ,@dimensions))))))) - -;;; The LIST, FLOAT and REAL types have special names. Other union -;;; types just get mechanically unparsed. -(define-type-method (union :unparse) (type) - (declare (type ctype type)) - (cond - ((type= type (specifier-type 'list)) 'list) - ((type= type (specifier-type 'float)) 'float) - ((type= type (specifier-type 'real)) 'real) - ((type= type (specifier-type 'sequence)) 'sequence) - ((type= type (specifier-type 'bignum)) 'bignum) - ((type= type (specifier-type 'simple-string)) 'simple-string) - ((type= type (specifier-type 'string)) 'string) - ;; In the absence of Unicode, STRING is not a union. - #+sb-unicode ((unparse-string-type type 'simple-string)) - #+sb-unicode ((unparse-string-type type 'string)) - ((type= type (specifier-type 'complex)) 'complex) - (t - ;; If NULL is in the union, and deleting it reduces the union to either an atom - ;; or a list whose head is [SIMPLE-]STRING, then return (OR X NULL). - ;; This simplifies (OR FLOAT NULL) and other things in the above exceptions. - (let ((type-without-null - (when (find (specifier-type 'null) (union-type-types type)) - (type-specifier (type-difference type (specifier-type 'null)))))) - (if (or (and (atom type-without-null) type-without-null) - (typep type-without-null '(cons (member string simple-string)))) - `(or ,type-without-null null) - `(or ,@(mapcar #'type-specifier (union-type-types type)))))))) - -;;; Two union types are equal if they are each subtypes of each -;;; other. We need to be this clever because our complex subtypep -;;; methods are now more accurate; we don't get infinite recursion -;;; because the simple-subtypep method delegates to complex-subtypep -;;; of the individual types of type1. - CSR, 2002-04-09 -;;; -;;; Previous comment, now obsolete, but worth keeping around because -;;; it is true, though too strong a condition: -;;; -;;; Two union types are equal if their subtypes are equal sets. -(define-type-method (union :simple-=) (type1 type2) - (multiple-value-bind (subtype certain?) - (csubtypep type1 type2) - (if subtype - (csubtypep type2 type1) - ;; we might as well become as certain as possible. - (if certain? - (values nil t) - (multiple-value-bind (subtype certain?) - (csubtypep type2 type1) - (declare (ignore subtype)) - (values nil certain?)))))) - -(define-type-method (union :complex-=) (type1 type2) - (declare (ignore type1)) - (if (some #'type-might-contain-other-types-p - (union-type-types type2)) - (values nil nil) - (values nil t))) - -;;; Similarly, a union type is a subtype of another if and only if -;;; every element of TYPE1 is a subtype of TYPE2. -(defun union-simple-subtypep (type1 type2) - (every/type (swapped-args-fun #'union-complex-subtypep-arg2) - type2 - (union-type-types type1))) - -(define-type-method (union :simple-subtypep) (type1 type2) - (union-simple-subtypep type1 type2)) - -(defun union-complex-subtypep-arg1 (type1 type2) - (every/type (swapped-args-fun #'csubtypep) - type2 - (union-type-types type1))) - -(define-type-method (union :complex-subtypep-arg1) (type1 type2) - (union-complex-subtypep-arg1 type1 type2)) - -(defun union-complex-subtypep-arg2 (type1 type2) - ;; At this stage, we know that type2 is a union type and type1 - ;; isn't. We might as well check this, though: - (aver (union-type-p type2)) - (aver (not (union-type-p type1))) - ;; was: (any/type #'csubtypep type1 (union-type-types type2)), which - ;; turns out to be too restrictive, causing bug 91. - ;; - ;; the following reimplementation might look dodgy. It is dodgy. It - ;; depends on the union :complex-= method not doing very much work - ;; -- certainly, not using subtypep. Reasoning: - ;; - ;; A is a subset of (B1 u B2) - ;; <=> A n (B1 u B2) = A - ;; <=> (A n B1) u (A n B2) = A - ;; - ;; But, we have to be careful not to delegate this type= to - ;; something that could invoke subtypep, which might get us back - ;; here -> stack explosion. We therefore ensure that the second type - ;; (which is the one that's dispatched on) is either a union type - ;; (where we've ensured that the complex-= method will not call - ;; subtypep) or something with no union types involved, in which - ;; case we'll never come back here. - ;; - ;; If we don't do this, then e.g. - ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR))) - ;; would loop infinitely, as the member :complex-= method is - ;; implemented in terms of subtypep. - ;; - ;; Ouch. - CSR, 2002-04-10 - (cond ((fun-designator-type-p type1) - (type= type2 (specifier-type 'function-designator))) - (t - (multiple-value-bind (sub-value sub-certain?) - (type= type1 - (%type-union - (mapcar (lambda (x) (type-intersection type1 x)) - (union-type-types type2)))) - (if sub-certain? - (values sub-value sub-certain?) - ;; The ANY/TYPE expression above is a sufficient condition for - ;; subsetness, but not a necessary one, so we might get a more - ;; certain answer by this CALL-NEXT-METHOD-ish step when the - ;; ANY/TYPE expression is uncertain. - (invoke-complex-subtypep-arg1-method type1 type2)))))) - -(define-type-method (union :complex-subtypep-arg2) (type1 type2) - (union-complex-subtypep-arg2 type1 type2)) - -(define-type-method (union :simple-intersection2 :complex-intersection2) - (type1 type2) - ;; The CSUBTYPEP clauses here let us simplify e.g. - ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST) - ;; (SPECIFIER-TYPE '(OR LIST VECTOR))) - ;; (where LIST is (OR CONS NULL)). - ;; - ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice - ;; versa, but it's important that we pre-expand them into - ;; specialized operations on individual elements of - ;; UNION-TYPE-TYPES, instead of using the ordinary call to - ;; CSUBTYPEP, in order to avoid possibly invoking any methods which - ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus - ;; cause infinite recursion. - ;; - ;; Within this method, type2 is guaranteed to be a union type: - (aver (union-type-p type2)) - ;; Make sure to call only the applicable methods... - (cond ((and (union-type-p type1) - (union-simple-subtypep type1 type2)) type1) - ((and (union-type-p type1) - (union-simple-subtypep type2 type1)) type2) - ((and (not (union-type-p type1)) - (union-complex-subtypep-arg2 type1 type2)) - type1) - ((and (not (union-type-p type1)) - (union-complex-subtypep-arg1 type2 type1)) - type2) - (t - ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2 - ;; operations in a particular order, and gives up if any of - ;; the sub-unions turn out not to be simple. In other cases - ;; ca. sbcl-0.6.11.15, that approach to taking a union was a - ;; bad idea, since it can overlook simplifications which - ;; might occur if the terms were accumulated in a different - ;; order. It's possible that that will be a problem here too. - ;; However, I can't think of a good example to demonstrate - ;; it, and without an example to demonstrate it I can't write - ;; test cases, and without test cases I don't want to - ;; complicate the code to address what's still a hypothetical - ;; problem. So I punted. -- WHN 2001-03-20 - (let ((accumulator *empty-type*)) - (dolist (t2 (union-type-types type2) accumulator) - (setf accumulator - (type-union accumulator - (type-intersection type1 t2)))))))) - -(def-type-translator or :list ((:context context) &rest type-specifiers) - ;; "* is not permitted as an argument to the OR type specifier." - (let ((type (%type-union (mapcar (lambda (x) (specifier-type x context 'or)) - type-specifiers)))) - (if (union-type-p type) - (sb-kernel::simplify-array-unions type) - type))) - -;;;; CONS types - -(def-type-translator cons ((:context context) - &optional (car-type-spec '*) (cdr-type-spec '*)) - (let ((car-type (single-value-specifier-type car-type-spec context)) - (cdr-type (single-value-specifier-type cdr-type-spec context))) - (make-cons-type car-type cdr-type))) - -(define-type-method (cons :negate) (type) - (if (and (eq (cons-type-car-type type) *universal-type*) - (eq (cons-type-cdr-type type) *universal-type*)) - (make-negation-type type) - (type-union - (make-negation-type (specifier-type 'cons)) - (cond - ((and (not (eq (cons-type-car-type type) *universal-type*)) - (not (eq (cons-type-cdr-type type) *universal-type*))) - (type-union - (make-cons-type - (type-negation (cons-type-car-type type)) - *universal-type*) - (make-cons-type - *universal-type* - (type-negation (cons-type-cdr-type type))))) - ((not (eq (cons-type-car-type type) *universal-type*)) - (make-cons-type - (type-negation (cons-type-car-type type)) - *universal-type*)) - ((not (eq (cons-type-cdr-type type) *universal-type*)) - (make-cons-type - *universal-type* - (type-negation (cons-type-cdr-type type)))) - (t (bug "Weird CONS type ~S" type)))))) - -(define-type-method (cons :unparse) (type) - (if (eq type (specifier-type 'cons)) - 'cons - `(cons ,(type-specifier (cons-type-car-type type)) - ,(type-specifier (cons-type-cdr-type type))))) - -(define-type-method (cons :simple-=) (type1 type2) - (declare (type cons-type type1 type2)) - (multiple-value-bind (car-match car-win) - (type= (cons-type-car-type type1) (cons-type-car-type type2)) - (multiple-value-bind (cdr-match cdr-win) - (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)) - (cond ((and car-match cdr-match) - (aver (and car-win cdr-win)) - (values t t)) - (t - (values nil - ;; FIXME: Ideally we would like to detect and handle - ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T - ;; but just returning a secondary true on (and car-win cdr-win) - ;; unfortunately breaks other things. --NS 2006-08-16 - (and (or (and (not car-match) car-win) - (and (not cdr-match) cdr-win)) - (not (and (cons-type-might-be-empty-type type1) - (cons-type-might-be-empty-type type2)))))))))) - -(define-type-method (cons :simple-subtypep) (type1 type2) - (declare (type cons-type type1 type2)) - (multiple-value-bind (val-car win-car) - (csubtypep (cons-type-car-type type1) (cons-type-car-type type2)) - (multiple-value-bind (val-cdr win-cdr) - (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) - (if (and val-car val-cdr) - (values t (and win-car win-cdr)) - (values nil (or (and (not val-car) win-car) - (and (not val-cdr) win-cdr))))))) - -;;; Give up if a precise type is not possible, to avoid returning -;;; overly general types. -(define-type-method (cons :simple-union2) (type1 type2) - (declare (type cons-type type1 type2)) - (let ((car-type1 (cons-type-car-type type1)) - (car-type2 (cons-type-car-type type2)) - (cdr-type1 (cons-type-cdr-type type1)) - (cdr-type2 (cons-type-cdr-type type2)) - car-not1 - car-not2) - ;; UGH. -- CSR, 2003-02-24 - (macrolet ((frob-car (car1 car2 cdr1 cdr2 - &optional not1) - `(let ((intersection (type-intersection ,car2 - ,(or not1 - `(type-negation ,car1))))) - (unless (type= intersection ,car2) - (type-union - (make-cons-type ,car1 (type-union ,cdr1 ,cdr2)) - (make-cons-type intersection ,cdr2)))))) - (cond ((type= car-type1 car-type2) - (make-cons-type car-type1 - (type-union cdr-type1 cdr-type2))) - ((type= cdr-type1 cdr-type2) - (make-cons-type (type-union car-type1 car-type2) - cdr-type1)) - ((csubtypep car-type1 car-type2) - (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) - ((csubtypep car-type2 car-type1) - (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) - ;; more general case of the above, but harder to compute - ((multiple-value-bind (yes win) - (csubtypep car-type2 (setf car-not1 (type-negation car-type1))) - (and (not yes) win)) - (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) - ((multiple-value-bind (yes win) - (csubtypep car-type1 (setf car-not2 (type-negation car-type2))) - (and (not yes) win)) - (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)) - ;; Don't put these in -- consider the effect of taking the - ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and - ;; (CONS (INTEGER 0 3) (INTEGER 5 6)). - #+nil - ((csubtypep cdr-type1 cdr-type2) - (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2)) - #+nil - ((csubtypep cdr-type2 cdr-type1) - (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1)))))) - -(define-type-method (cons :simple-intersection2) (type1 type2) - (declare (type cons-type type1 type2)) - (let ((car-int2 (type-intersection2 (cons-type-car-type type1) - (cons-type-car-type type2))) - (cdr-int2 (type-intersection2 (cons-type-cdr-type type1) - (cons-type-cdr-type type2)))) - (cond - ((and car-int2 cdr-int2) (make-cons-type car-int2 cdr-int2)) - (car-int2 (make-cons-type car-int2 - (type-intersection - (cons-type-cdr-type type1) - (cons-type-cdr-type type2)))) - (cdr-int2 (make-cons-type - (type-intersection (cons-type-car-type type1) - (cons-type-car-type type2)) - cdr-int2))))) - -(!define-superclasses cons ((cons)) !cold-init-forms) - -;;;; CHARACTER-SET types - -(def-type-translator character-set - (&optional (pairs `((0 . ,(1- char-code-limit))))) - (make-character-set-type pairs)) - -(define-type-method (character-set :negate) (type) - (let ((pairs (character-set-type-pairs type))) - (if (and (= (length pairs) 1) - (= (caar pairs) 0) - (= (cdar pairs) (1- char-code-limit))) - (make-negation-type type) - (let ((not-character - (make-negation-type - (make-character-set-type - `((0 . ,(1- char-code-limit))))))) - (type-union - not-character - (make-character-set-type - (let (not-pairs) - (when (> (caar pairs) 0) - (push (cons 0 (1- (caar pairs))) not-pairs)) - (do* ((tail pairs (cdr tail)) - (high1 (cdar tail) (cdar tail)) - (low2 (caadr tail) (caadr tail))) - ((null (cdr tail)) - (when (< (cdar tail) (1- char-code-limit)) - (push (cons (1+ (cdar tail)) - (1- char-code-limit)) - not-pairs)) - (nreverse not-pairs)) - (push (cons (1+ high1) (1- low2)) not-pairs))))))))) - -(define-type-method (character-set :unparse) (type) - (cond - ((eq type (specifier-type 'character)) 'character) - ((eq type (specifier-type 'base-char)) 'base-char) - ((eq type (specifier-type 'extended-char)) 'extended-char) - ;; standard-char is not an interned type - ((type= type (specifier-type 'standard-char)) 'standard-char) - (t - ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there - ;; are at most as many characters as there are character code ranges. - ;; (basically saying to use MEMBER if each range is one character) - (let* ((pairs (character-set-type-pairs type)) - (count (length pairs)) - (chars (loop named outer - for (low . high) in pairs - nconc (loop for code from low upto high - collect (sb-xc:code-char code) - when (minusp (decf count)) - do (return-from outer t))))) - (if (eq chars t) - `(character-set ,pairs) - `(member ,@chars)))))) - -(define-type-method (character-set :singleton-p) (type) - (let* ((pairs (character-set-type-pairs type)) - (pair (first pairs))) - (if (and (typep pairs '(cons t null)) - (eql (car pair) (cdr pair))) - (values t (code-char (car pair))) - (values nil nil)))) - -(define-type-method (character-set :simple-=) (type1 type2) - (let ((pairs1 (character-set-type-pairs type1)) - (pairs2 (character-set-type-pairs type2))) - (values (equal pairs1 pairs2) t))) - -(define-type-method (character-set :simple-subtypep) (type1 type2) - (values - (dolist (pair (character-set-type-pairs type1) t) - (unless (position pair (character-set-type-pairs type2) - :test (lambda (x y) (and (>= (car x) (car y)) - (<= (cdr x) (cdr y))))) - (return nil))) - t)) - -(define-type-method (character-set :simple-union2) (type1 type2) - ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function - ;; actually does the union for us. It might be a little fragile to - ;; rely on it. - (make-character-set-type - (merge 'list - (copy-alist (character-set-type-pairs type1)) - (copy-alist (character-set-type-pairs type2)) - #'< :key #'car))) - -(define-type-method (character-set :simple-intersection2) (type1 type2) - ;; KLUDGE: brute force. -#| - (let (pairs) - (dolist (pair1 (character-set-type-pairs type1) - (make-character-set-type - (sort pairs #'< :key #'car))) - (dolist (pair2 (character-set-type-pairs type2)) - (cond - ((<= (car pair1) (car pair2) (cdr pair1)) - (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs)) - ((<= (car pair2) (car pair1) (cdr pair2)) - (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs)))))) -|# - (make-character-set-type - (intersect-type-pairs - (character-set-type-pairs type1) - (character-set-type-pairs type2)))) - -;;; -;;; Intersect two ordered lists of pairs -;;; Each list is of the form ((start1 . end1) ... (startn . endn)), -;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn. -;;; Each pair represents the integer interval start..end. -;;; -(defun intersect-type-pairs (alist1 alist2) - (if (and alist1 alist2) - (let ((res nil) - (pair1 (pop alist1)) - (pair2 (pop alist2))) - (loop - (when (> (car pair1) (car pair2)) - (rotatef pair1 pair2) - (rotatef alist1 alist2)) - (let ((pair1-cdr (cdr pair1))) - (cond - ((> (car pair2) pair1-cdr) - ;; No over lap -- discard pair1 - (unless alist1 (return)) - (setq pair1 (pop alist1))) - ((<= (cdr pair2) pair1-cdr) - (push (cons (car pair2) (cdr pair2)) res) - (cond - ((= (cdr pair2) pair1-cdr) - (unless alist1 (return)) - (unless alist2 (return)) - (setq pair1 (pop alist1) - pair2 (pop alist2))) - (t ;; (< (cdr pair2) pair1-cdr) - (unless alist2 (return)) - (setq pair1 (cons (1+ (cdr pair2)) pair1-cdr)) - (setq pair2 (pop alist2))))) - (t ;; (> (cdr pair2) (cdr pair1)) - (push (cons (car pair2) pair1-cdr) res) - (unless alist1 (return)) - (setq pair2 (cons (1+ pair1-cdr) (cdr pair2))) - (setq pair1 (pop alist1)))))) - (nreverse res)) - nil)) - - -;;; Return the type that describes all objects that are in X but not -;;; in Y. -(defun type-difference (x y) - (type-intersection x (type-negation y))) - -(def-type-translator array ((:context context) - &optional (element-type '*) - (dimensions '*)) - (let ((eltype (if (eq element-type '*) - *wild-type* - (specifier-type element-type context)))) - (make-array-type (canonical-array-dimensions dimensions) - :complexp :maybe - :element-type eltype - :specialized-element-type (%upgraded-array-element-type - eltype)))) - -(def-type-translator simple-array ((:context context) - &optional (element-type '*) - (dimensions '*)) - (let ((eltype (if (eq element-type '*) - *wild-type* - (specifier-type element-type context)))) - (make-array-type (canonical-array-dimensions dimensions) - :complexp nil - :element-type eltype - :specialized-element-type (%upgraded-array-element-type - eltype)))) - -;;;; SIMD-PACK types -#+sb-simd-pack -(progn - (define-type-class simd-pack :enumerable nil - :might-contain-other-types nil) - - ;; Though this involves a recursive call to parser, parsing context need not - ;; be passed down, because an unknown-type condition is an immediate failure. - (def-type-translator simd-pack (&optional (element-type-spec '*)) - (if (eql element-type-spec '*) - (%make-simd-pack-type *simd-pack-element-types*) - (make-simd-pack-type (single-value-specifier-type element-type-spec)))) - - (define-type-method (simd-pack :negate) (type) - (let ((remaining (set-difference *simd-pack-element-types* - (simd-pack-type-element-type type))) - (not-simd-pack (make-negation-type (specifier-type 'simd-pack)))) - (if remaining - (type-union not-simd-pack (%make-simd-pack-type remaining)) - not-simd-pack))) - - (define-type-method (simd-pack :unparse) (type) - (let ((eltypes (simd-pack-type-element-type type))) - (cond ((equal eltypes *simd-pack-element-types*) - 'simd-pack) - ((= 1 (length eltypes)) - `(simd-pack ,(first eltypes))) - (t - `(or ,@(mapcar (lambda (eltype) - `(simd-pack ,eltype)) - eltypes)))))) - - (define-type-method (simd-pack :simple-=) (type1 type2) - (declare (type simd-pack-type type1 type2)) - (values - (null (set-exclusive-or (simd-pack-type-element-type type1) - (simd-pack-type-element-type type2))) - t)) - - (define-type-method (simd-pack :simple-subtypep) (type1 type2) - (declare (type simd-pack-type type1 type2)) - (subsetp (simd-pack-type-element-type type1) - (simd-pack-type-element-type type2))) - - (define-type-method (simd-pack :simple-union2) (type1 type2) - (declare (type simd-pack-type type1 type2)) - (%make-simd-pack-type (union (simd-pack-type-element-type type1) - (simd-pack-type-element-type type2)))) - - (define-type-method (simd-pack :simple-intersection2) (type1 type2) - (declare (type simd-pack-type type1 type2)) - (let ((intersection (intersection (simd-pack-type-element-type type1) - (simd-pack-type-element-type type2)))) - (if intersection - (%make-simd-pack-type intersection) - *empty-type*))) - - (!define-superclasses simd-pack ((simd-pack)) !cold-init-forms)) - -#+sb-simd-pack-256 -(progn - (define-type-class simd-pack-256 :enumerable nil - :might-contain-other-types nil) - - ;; Though this involves a recursive call to parser, parsing context need not - ;; be passed down, because an unknown-type condition is an immediate failure. - (def-type-translator simd-pack-256 (&optional (element-type-spec '*)) - (if (eql element-type-spec '*) - (%make-simd-pack-256-type *simd-pack-element-types*) - (make-simd-pack-256-type (single-value-specifier-type element-type-spec)))) - - (define-type-method (simd-pack-256 :negate) (type) - (let ((remaining (set-difference *simd-pack-element-types* - (simd-pack-256-type-element-type type))) - (not-simd-pack-256 (make-negation-type (specifier-type 'simd-pack-256)))) - (if remaining - (type-union not-simd-pack-256 (%make-simd-pack-256-type remaining)) - not-simd-pack-256))) - - (define-type-method (simd-pack-256 :unparse) (type) - (let ((eltypes (simd-pack-256-type-element-type type))) - (cond ((equal eltypes *simd-pack-element-types*) - 'simd-pack-256) - ((= 1 (length eltypes)) - `(simd-pack-256 ,(first eltypes))) - (t - `(or ,@(mapcar (lambda (eltype) - `(simd-pack-256 ,eltype)) - eltypes)))))) - - (define-type-method (simd-pack-256 :simple-=) (type1 type2) - (declare (type simd-pack-256-type type1 type2)) - (values - (null (set-exclusive-or (simd-pack-256-type-element-type type1) - (simd-pack-256-type-element-type type2))) - t)) - - (define-type-method (simd-pack-256 :simple-subtypep) (type1 type2) - (declare (type simd-pack-256-type type1 type2)) - (subsetp (simd-pack-256-type-element-type type1) - (simd-pack-256-type-element-type type2))) - - (define-type-method (simd-pack-256 :simple-union2) (type1 type2) - (declare (type simd-pack-256-type type1 type2)) - (%make-simd-pack-256-type (union (simd-pack-256-type-element-type type1) - (simd-pack-256-type-element-type type2)))) - - (define-type-method (simd-pack-256 :simple-intersection2) (type1 type2) - (declare (type simd-pack-256-type type1 type2)) - (let ((intersection (intersection (simd-pack-256-type-element-type type1) - (simd-pack-256-type-element-type type2)))) - (if intersection - (%make-simd-pack-256-type intersection) - *empty-type*))) - - (!define-superclasses simd-pack-256 ((simd-pack-256)) !cold-init-forms)) - -;;;; utilities shared between cross-compiler and target system - -;;; Does the type derived from compilation of an actual function -;;; definition satisfy declarations of a function's type? -(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype) - (declare (type ctype defined-ftype declared-ftype)) - (flet ((is-built-in-class-function-p (ctype) - (and (built-in-classoid-p ctype) - (eq (built-in-classoid-name ctype) 'function)))) - (cond (;; DECLARED-FTYPE could certainly be #; - ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). - (is-built-in-class-function-p declared-ftype) - ;; In that case, any definition satisfies the declaration. - t) - (;; It's not clear whether or how DEFINED-FTYPE might be - ;; #, but it's not obviously - ;; invalid, so let's handle that case too, just in case. - (is-built-in-class-function-p defined-ftype) - ;; No matter what DECLARED-FTYPE might be, we can't prove - ;; that an object of type FUNCTION doesn't satisfy it, so - ;; we return success no matter what. - t) - (;; Otherwise both of them must be FUN-TYPE objects. - t - ;; FIXME: For now we only check compatibility of the return - ;; type, not argument types, and we don't even check the - ;; return type very precisely (as per bug 94a). It would be - ;; good to do a better job. Perhaps to check the - ;; compatibility of the arguments, we should (1) redo - ;; VALUES-TYPES-EQUAL-OR-INTERSECT as - ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to - ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE - ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) - (values-types-equal-or-intersect - (fun-type-returns defined-ftype) - (fun-type-returns declared-ftype)))))) - -;;; This messy case of CTYPE for NUMBER is shared between the -;;; cross-compiler and the target system. -;;; I'm not sure whether NaNs should be numeric types versus MEMBER (like -;;; sigleton signed zero without the "other" sign), but it may not matter. -;;; At a bare minimum this prevents crashing in min/max. -(defun ctype-of-number (x) - (let ((num (if (complexp x) (realpart x) x))) - (multiple-value-bind (complexp low high) - (cond ((complexp x) - (let ((imag (imagpart x))) - (if (and (floatp num) (or (float-nan-p num) (float-nan-p imag))) - (values :complex nil nil) - (values :complex (sb-xc:min num imag) (sb-xc:max num imag))))) - ((and (floatp num) (float-nan-p num)) - (values :real nil nil)) - (t - (values :real num num))) - (make-numeric-type :class (etypecase num - (integer (if (complexp x) - (if (integerp (imagpart x)) - 'integer - 'rational) - 'integer)) - (rational 'rational) - (float 'float)) - :format (and (floatp num) (float-format-name num)) - :complexp complexp - :low low - :high high)))) - -;;; The following function is a generic driver for approximating -;;; set-valued functions over types. Putting this here because it'll -;;; probably be useful for a lot of type analyses. -;;; -;;; Let f be a function from values of type X to Y, e.g., ARRAY-RANK. -;;; -;;; We compute an over or under-approximation of the set -;;; -;;; F(TYPE) = { f(x) : x in TYPE /\ x in X } \subseteq Y -;;; -;;; via set-valued approximations of f, OVER and UNDER. -;;; -;;; These functions must have the property that -;;; Forall TYPE, OVER(TYPE) \superseteq F(TYPE) and -;;; Forall TYPE, UNDER(TYPE) \subseteq F(TYPE) -;;; -;;; The driver is also parameterised over the finite set -;;; representation. -;;; -;;; Union, intersection and difference are binary functions to compute -;;; set union, intersection and difference. Top and bottom are the -;;; concrete representations for the universe and empty sets; we never -;;; call the set functions on top or bottom, so it's safe to use -;;; special values there. -;;; -;;; Arguments: -;;; -;;; TYPE: the ctype for which we wish to approximate F(TYPE) -;;; OVERAPPROXIMATE: true if we wish to overapproximate, nil otherwise. -;;; You usually want T. -;;; UNION/INTERSECTION/DIFFERENCE: implementations of finite set operations. -;;; Conform to cl::(union/intersection/set-difference). Passing NIL will -;;; disable some cleverness and result in quicker computation of coarser -;;; approximations. However, passing difference without union and intersection -;;; will probably not end well. -;;; TOP/BOTTOM: concrete representation of the universe and empty set. Finite -;;; set operations are never called on TOP/BOTTOM, so it's safe to use special -;;; values there. -;;; OVER/UNDER: the set-valued approximations of F. -;;; -;;; Implementation details. -;;; -;;; It's a straightforward walk down the type. -;;; Union types -> take the union of children, intersection -> -;;; intersect. There is some complication for negation types: we must -;;; not only negate the result, but also flip from overapproximating -;;; to underapproximating in the children (or vice versa). -;;; -;;; We represent sets as a pair of (negate-p finite-set) in order to -;;; support negation types. - -(declaim (inline generic-abstract-type-function)) -(defun generic-abstract-type-function - (type overapproximate - union intersection difference - top bottom - over under) - (labels ((union* (x y) - ;; wrappers to avoid calling union/intersection on - ;; top/bottom. - (cond ((or (eql x top) - (eql y top)) - top) - ((eql x bottom) y) - ((eql y bottom) x) - (t - (funcall union x y)))) - (intersection* (x y) - (cond ((or (eql x bottom) - (eql y bottom)) - bottom) - ((eql x top) y) - ((eql y top) x) - (t - (funcall intersection x y)))) - (unite (not-x-p x not-y-p y) - ;; if we only have one negated set, it's x. - (when not-y-p - (rotatef not-x-p not-y-p) - (rotatef x y)) - (cond ((and not-x-p not-y-p) - ;; -x \/ -y = -(x /\ y) - (normalize t (intersection* x y))) - (not-x-p - ;; -x \/ y = -(x \ y) - (cond ((eql x top) - (values nil y)) - ((or (eql y top) - (eql x bottom)) - (values nil top)) - ((eql y bottom) - (values t x)) - (t - (normalize t - (funcall difference x y))))) - (t - (values nil (union* x y))))) - (intersect (not-x-p x not-y-p y) - (when not-y-p - (rotatef not-x-p not-y-p) - (rotatef x y)) - (cond ((and not-x-p not-y-p) - ;; -x /\ -y = -(x \/ y) - (normalize t (union* x y))) - (not-x-p - ;; -x /\ y = y \ x - (cond ((or (eql x top) (eql y bottom)) - (values nil bottom)) - ((eql x bottom) - (values nil y)) - ((eql y top) - (values t x)) - (t - (values nil (funcall difference y x))))) - (t - (values nil (intersection* x y))))) - (normalize (not-x-p x) - ;; catch some easy cases of redundant negation. - (cond ((not not-x-p) - (values nil x)) - ((eql x top) - bottom) - ((eql x bottom) - top) - (t - (values t x)))) - (default (overapproximate) - ;; default value - (if overapproximate top bottom)) - (walk-union (types overapproximate) - ;; Only do this if union is provided. - (unless union - (return-from walk-union (default overapproximate))) - ;; Reduce/union from bottom. - (let ((not-acc-p nil) - (acc bottom)) - (dolist (type types (values not-acc-p acc)) - (multiple-value-bind (not x) - (walk type overapproximate) - (setf (values not-acc-p acc) - (unite not-acc-p acc not x))) - ;; Early exit on top set. - (when (and (eql acc top) - (not not-acc-p)) - (return (values nil top)))))) - (walk-intersection (types overapproximate) - ;; Skip if we don't know how to intersect sets - (unless intersection - (return-from walk-intersection (default overapproximate))) - ;; Reduce/intersection from top - (let ((not-acc-p nil) - (acc top)) - (dolist (type types (values not-acc-p acc)) - (multiple-value-bind (not x) - (walk type overapproximate) - (setf (values not-acc-p acc) - (intersect not-acc-p acc not x))) - (when (and (eql acc bottom) - (not not-acc-p)) - (return (values nil bottom)))))) - (walk-negate (type overapproximate) - ;; Don't introduce negated types if we don't know how to - ;; subtract sets. - (unless difference - (return-from walk-negate (default overapproximate))) - (multiple-value-bind (not x) - (walk type (not overapproximate)) - (normalize (not not) x))) - (walk (type overapproximate) - (typecase type - (union-type - (walk-union (union-type-types type) overapproximate)) - ((cons (member or union)) - (walk-union (rest type) overapproximate)) - (intersection-type - (walk-intersection (intersection-type-types type) overapproximate)) - ((cons (member and intersection)) - (walk-intersection (rest type) overapproximate)) - (negation-type - (walk-negate (negation-type-type type) overapproximate)) - ((cons (eql not)) - (walk-negate (second type) overapproximate)) - (t - (values nil - (if overapproximate - (if over - (funcall over type) - (default t)) - (if under - (funcall under type) - (default nil)))))))) - (multiple-value-call #'normalize (walk type overapproximate)))) -(declaim (notinline generic-abstract-type-function)) - -;;; Standard list representation of sets. Use CL:* for the universe. -(defun list-abstract-type-function (type over &key under (overapproximate t)) - (declare (inline generic-abstract-type-function)) - (generic-abstract-type-function - type overapproximate - #'union #'intersection #'set-difference - '* nil - over under)) - -(!defun-from-collected-cold-init-forms !late-type-cold-init) - -(/show0 "late-type.lisp end of file") diff -Nru sbcl-2.1.1/src/code/list.lisp sbcl-2.1.11/src/code/list.lisp --- sbcl-2.1.1/src/code/list.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/list.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1107,7 +1107,11 @@ (dolist (elt list1) (unless (funcall member-test elt list2 key test) (push elt result))) - (dx-flet ((test (x y) (funcall (truly-the function test) y x))) + (dx-flet ((test (x y) + ;; This local function is never called if TEST is NIL, + ;; but the compiler doesn't know that, suppress the warning. + (funcall (the* (function :truly t :silent-conflict t) test) + y x))) (dolist (elt list2) (unless (funcall member-test elt list1 key #'test) (push elt result))))) @@ -1190,7 +1194,11 @@ (defun acons (key datum alist) "Construct a new alist by adding the pair (KEY . DATUM) to ALIST." - (cons (cons key datum) alist)) + ;; This function is maybe-inline, so can't use vop-existsp + ;; which does not remain in the image post-build. + #.(if (gethash 'acons sb-c::*backend-template-names*) + '(acons key datum alist) ; vop translated + '(cons (cons key datum) alist))) (defun pairlis (keys data &optional (alist '())) "Construct an association list from KEYS and DATA (adding to ALIST)." diff -Nru sbcl-2.1.1/src/code/load.lisp sbcl-2.1.11/src/code/load.lisp --- sbcl-2.1.1/src/code/load.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/load.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -15,9 +15,129 @@ ;;;; files for more information. (in-package "SB-FASL") + + +;;;; various constants and essentially-constants + +;;; a string which appears at the start of a fasl file header +;;; +;;; This value is used to identify fasl files. Even though this is not +;;; declared as a constant (because ANSI Common Lisp has no facility +;;; for declaring values which are constant under EQUAL but not EQL), +;;; obviously you shouldn't mess with it lightly. If you do set a new +;;; value for some reason, keep these things in mind: +;;; * To avoid confusion with the similar but incompatible CMU CL +;;; fasl file format, the value should not be "FASL FILE", which +;;; is what CMU CL used for the same purpose. +;;; * Since its presence at the head of a file is used by LOAD to +;;; decide whether a file is to be fasloaded or just loaded +;;; ordinarily (as source), the value should be something which +;;; can't legally appear at the head of a Lisp source file. +;;; * The value should not contain any line-terminating characters, +;;; because they're hard to express portably and because the LOAD +;;; code might reasonably use READ-LINE to get the value to compare +;;; against. +(defglobal *fasl-header-string-start-string* "# FASL") + +;;; a list of SB-XC:*FEATURES* flags which affect binary compatibility, +;;; i.e. which must be the same between the SBCL which compiled the code +;;; and the SBCL which executes the code. This is a property of SBCL executables +;;; in the abstract, not of this particular SBCL executable, +;;; so any flag in this list may or may not be present +;;; in the *FEATURES* list of this particular build. +(defglobal *features-potentially-affecting-fasl-format* + (append '(:sb-thread :sb-unicode :cheneygc :gencgc :msan :sb-safepoint))) + +;;; the code for a character which terminates a fasl file header +(defconstant +fasl-header-string-stop-char-code+ 255) + +;;; This value should be incremented when the system changes in such a +;;; way that it will no longer work reliably with old fasl files. In +;;; practice, I (WHN) have often forgotten to increment it for CVS +;;; versions which break binary compatibility. But it certainly should +;;; be incremented for release versions which break binary +;;; compatibility. +(defconstant +fasl-file-version+ 78) +;;; (description of versions before 0.9.0.1 deleted in 0.9.17) +;;; 56: (2005-05-22) Something between 0.9.0.1 and 0.9.0.14. My money is +;;; on 0.9.0.6 (MORE CASE CONSISTENCY). +;;; 57: (2005-06-12) Raw slot rearrangement in 0.9.1.38 +;;; 58: (2005-08-16) Multiple incompatible changes between 0.9.3 and 0.9.3.60 +;;; 59: (2005-09-18) METAOBJECT implementation, removal of INSTANCE and +;;; FUNCALLABLE-INSTANCE classes. +;;; 60: (2005-10-24) Bumped for 0.9.6 +;;; 61: (2005-11-06) Improved source location recording added extra parameters +;;; to multiple %DEFMUMBLE functions. +;;; 62: (2005-12-30) Make the count of FASL header counted strings +;;; a 32-bit value also on 64-bit platforms. +;;; 63: (2006-01-27) Shuffle storage classes around to reduce the error +;;; trap information size on RISCy platforms. +;;; 64: (2006-03-24) New calling convention for unknown-values on x86 and +;;; x86-64. Also (belatedly) PPC/gencgc, including :gencgc on FPAFF. +;;; 65: (2006-04-11) Package locking interface changed. +;;; 66: (2006-05-13) Fopcompiler +;;; 67: (2006-07-25) Reports on #lisp about 0.9.13 fasls being invalid on +;;; 0.9.14.something +;;; 68: (2006-08-14) changed number of arguments of LOAD-DEFMETHOD +;;; 69: (2006-08-17) changed validity of various initargs for methods +;;; 70: (2006-09-13) changes to *PSEUDO-ATOMIC* on x86 and x86-64 +;;; 71: (2006-11-19) CLOS calling convention changes +;;; 72: (2006-12-05) Added slot to the primitive function type +;;; 73: (2007-04-13) Changed a hash function +;;; 74: (2007-06-05) UNWIND-TO-FRAME-AND-CALL +;;; 75: (2007-08-06) FD-STREAM layout changes +;;; 76: (2007-10-05) MUTEX layout changes +;;; 77: (2007-11-08) Essentially obsolete fasl-file-version, fasls are now +;;; considered compatible only when the version numbers of the compiling +;;; SBCL instance is exactly the same as the one of the loading instance. +;;; Further fasl-file-version bumps should only be done for real changes +;;; in the fasl format, not for changes in function/macro signatures or +;;; lisp data structures. +;;; 78: (2010-04-02) Add FOP-{SMALL-,}NAMED-PACKAGE, remove FOP-NORMAL-LOAD +;;; and FOP-MAYBE-COLD-LOAD. + +;;; the conventional file extension for our fasl files +;;; FIXME this should be (DEFCONSTANT-EQX +FASL-FILE-TYPE+ "fasl" #'EQUAL), +;;; but renaming the variable would harm 'asdf-dependency-grovel' and other +;;; random 3rd-party libraries. However, we can't keep the name and make it +;;; constant, because the compiler warns about asterisks on constants. +;;; So we keep the asterisks and make it defglobal. +(declaim (type simple-string *fasl-file-type*)) +(defglobal *fasl-file-type* "fasl") + +;;;; internal state variables + +(defvar *load-depth* 0 + "the current number of recursive LOADs") +(declaim (type index *load-depth*)) + ;;;; miscellaneous load utilities +(defun make-fop-vector (size) + (declare (type index size)) + (let ((vector (make-array size))) + (setf (aref vector 0) 0) + vector)) + +;;; a holder for the FASL file we're reading from +(defstruct (fasl-input (:conc-name %fasl-input-) + (:constructor make-fasl-input (stream)) + (:predicate nil) + (:copier nil)) + (stream nil :type ansi-stream :read-only t) + (table (make-fop-vector 1000) :type simple-vector) + (stack (make-fop-vector 100) :type simple-vector) + (name-buffer (vector (make-string 1 :element-type 'character) + (make-string 31 :element-type 'base-char))) + (deprecated-stuff nil :type list) + ;; Sometimes we want to skip over any FOPs with side-effects (like + ;; function calls) while executing other FOPs. SKIP-UNTIL will + ;; either contain the position where the skipping will stop, or + ;; NIL if we're executing normally. + (skip-until nil :type (or null fixnum))) +(declaim (freeze-type fasl-input)) + ;;; Output the current number of semicolons after a fresh-line. ;;; FIXME: non-mnemonic name (defun load-fresh-line () @@ -183,6 +303,107 @@ (setf (svref stack 0) next (svref stack next) value))) +;;; Bind STACK-VAR and PTR-VAR to the start of a subsequence of +;;; the fop stack of length COUNT, then execute BODY. +;;; Within the body, FOP-STACK-REF is used in lieu of SVREF +;;; to elide bounds checking. +(defmacro with-fop-stack (((stack-var &optional stack-expr) ptr-var count) + &body body) + `(macrolet ((fop-stack-ref (i) + `(locally + #-sb-xc-host + (declare (optimize (sb-c:insert-array-bounds-checks 0))) + (svref ,',stack-var (truly-the index ,i))))) + (let* (,@(when stack-expr + (list `(,stack-var (the simple-vector ,stack-expr)))) + (,ptr-var (truly-the index (fop-stack-pop-n ,stack-var ,count)))) + ,@body))) + + +;;;; the FOP database + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; The bottom 5 bits of the opcodes above 128 encode an implicit operand. + (defconstant n-ordinary-fops 128)) + +;;; a vector indexed by a FaslOP that yields a function which performs +;;; the operation. Most functions take 0 arguments - they only manipulate +;;; the fop stack. But if the fop is defined to receive an argument (or two) +;;; then loader's main loop is responsible for supplying it. +(defglobal **fop-funs** (make-array n-ordinary-fops :initial-element 0)) +(declaim (type (simple-vector #.n-ordinary-fops) **fop-funs**)) + +;;; Two arrays indicate fop function signature. +;;; The first array indicates how many integer operands follow the opcode. +;;; The second tells whether the fop wants its result pushed on the stack. +(declaim (type (cons (simple-array (mod 4) (#.n-ordinary-fops)) + (simple-bit-vector #.n-ordinary-fops)) + **fop-signatures**)) +(defglobal **fop-signatures** + (cons (make-array n-ordinary-fops :element-type '(mod 4) :initial-element 0) + (make-array n-ordinary-fops :element-type 'bit :initial-element 0))) + + +;;; Define NAME as a fasl operation, with op-code FOP-CODE. +;;; PUSHP describes what the body does to the fop stack: +;;; T - The result of the body is pushed on the fop stack. +;;; NIL - The result of the body is discarded. +;;; In either case, the body is permitted to pop the stack. +;;; +(defmacro define-fop (fop-code &rest stuff) + (multiple-value-bind (name allowp operands stack-args pushp forms) + (let ((allowp (if (eq (car stuff) :not-host) + (progn (pop stuff) (or #-sb-xc-host t)) + t))) + (destructuring-bind ((name &optional arglist (pushp t)) . forms) stuff + (aver (member pushp '(nil t))) + (multiple-value-bind (operands stack-args) + (if (atom (car arglist)) + (values nil arglist) + (ecase (caar arglist) + (:operands (values (cdar arglist) (cdr arglist))))) + (assert (<= (length operands) 3)) + (values name allowp operands stack-args pushp forms)))) + `(progn + (defun ,name (.fasl-input. ,@operands) + (declare (ignorable .fasl-input.)) + ,@(if allowp + `((macrolet + ((fasl-input () '(truly-the fasl-input .fasl-input.)) + (fasl-input-stream () '(%fasl-input-stream (fasl-input))) + (operand-stack () '(%fasl-input-stack (fasl-input))) + (skip-until () '(%fasl-input-skip-until (fasl-input)))) + ,@(if (null stack-args) + forms + (with-unique-names (stack ptr) + `((with-fop-stack ((,stack (operand-stack)) + ,ptr ,(length stack-args)) + (multiple-value-bind ,stack-args + (values ,@(loop for i below (length stack-args) + collect `(fop-stack-ref (+ ,ptr ,i)))) + ,@forms))))))) + `((declare (ignore ,@operands)) + (error ,(format nil "Not-host fop invoked: ~A" name))))) + (!%define-fop ',name ,fop-code ,(length operands) ,(if pushp 1 0))))) + +(defun !%define-fop (name opcode n-operands pushp) + (declare (type (mod 4) n-operands)) + (let ((function (svref **fop-funs** opcode))) + (when (functionp function) + (let ((oname (nth-value 2 (function-lambda-expression function)))) + (when (and oname (not (eq oname name))) + (error "fop ~S with opcode ~D conflicts with fop ~S." + name opcode oname)))) + (let ((existing-opcode (get name 'opcode))) + (when (and existing-opcode (/= existing-opcode opcode)) + (error "multiple codes for fop name ~S: ~D and ~D" + name opcode existing-opcode))) + (setf (get name 'opcode) opcode + (svref **fop-funs** opcode) (symbol-function name) + (aref (car **fop-signatures**) opcode) n-operands + (sbit (cdr **fop-signatures**) opcode) pushp)) + name) + ;;;; Conditions signalled on invalid fasls (wrong fasl version, etc), ;;;; so that user code (esp. ASDF) can reasonably handle attempts to diff -Nru sbcl-2.1.1/src/code/loop.lisp sbcl-2.1.11/src/code/loop.lisp --- sbcl-2.1.1/src/code/loop.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/loop.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -94,7 +94,8 @@ ((head-var tail-var &optional user-head-var) &body body) (let ((l (and user-head-var (list (list user-head-var nil))))) `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) - (declare (truly-dynamic-extent ,head-var)) + (declare (truly-dynamic-extent ,head-var) + ,@(and user-head-var `((list ,user-head-var)))) ,@body))) (sb-xc:defmacro loop-collect-rplacd @@ -140,13 +141,13 @@ (when user-head-var (setq answer `(progn ,answer - (setq ,user-head-var (cdr ,head-var))))) + (setq ,user-head-var (sb-ext:truly-the list (cdr ,head-var)))))) answer)))) (sb-xc:defmacro loop-collect-answer (head-var - &optional user-head-var) - (or user-head-var - `(cdr ,head-var))) + &optional user-head-var) + `(sb-ext:truly-the list ,(or user-head-var + `(cdr ,head-var)))) ;;;; maximization technology @@ -769,6 +770,9 @@ ""))) #+sb-unicode ((csubtypep ctype (specifier-type 'extended-char)) + #+sb-xc-host + (error "Unimplemented on cross-compiler.") + #-sb-xc-host (code-char base-char-code-limit)) ((csubtypep ctype (specifier-type 'character)) #\x) @@ -1364,7 +1368,7 @@ (defun loop-for-across (var val data-type) (loop-make-var var nil data-type) - (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-")) + (let ((vector-var (sb-xc:gensym "LOOP-ACROSS-VECTOR-")) (index-var (gensym "LOOP-ACROSS-INDEX-"))) (multiple-value-bind (vector-form constantp vector-value) (loop-constant-fold-if-possible val 'vector) @@ -1646,14 +1650,14 @@ (setq endform (if limit-constantp `',limit-value (loop-make-var - (gensym "LOOP-LIMIT-") form + (sb-xc:gensym "LOOP-LIMIT-") form `(and ,indexv-type real))))) (:by (multiple-value-setq (form stepby-constantp stepby) (loop-constant-fold-if-possible form `(and ,indexv-type (real (0))))) (unless stepby-constantp - (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-")) + (loop-make-var (setq stepby (sb-xc:gensym "LOOP-STEP-BY-")) form `(and ,indexv-type (real (0))) t))) diff -Nru sbcl-2.1.1/src/code/macroexpand.lisp sbcl-2.1.11/src/code/macroexpand.lisp --- sbcl-2.1.1/src/code/macroexpand.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/macroexpand.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,7 +18,7 @@ (declare (symbol symbol)) (eq (info :function :kind symbol) :special-form)) -(defvar sb-xc:*macroexpand-hook* 'funcall +(defvar *macroexpand-hook* 'funcall "The value of this variable must be a designator for a function that can take three arguments, a macro expander function, the macro form to be expanded, and the lexical environment to expand in. The function should @@ -59,7 +59,7 @@ :datum hook :expected-type 'compiled-function)))) -(defun sb-xc:macroexpand-1 (form &optional env) +(defun macroexpand-1 (form &optional env) "If form is a macro (or symbol macro), expand it once. Return two values, the expanded form and a T-or-NIL flag indicating whether the form was, in fact, a macro. ENV is the lexical environment to expand in, which defaults @@ -110,7 +110,7 @@ (t (values form nil))))) -(defun sb-xc:macroexpand (form &optional env) +(defun macroexpand (form &optional env) "Repetitively call MACROEXPAND-1 until the form can no longer be expanded. Returns the final resultant form, and T if it was expanded. ENV is the lexical environment to expand in, or NIL (the default) for the null @@ -140,3 +140,35 @@ (frob new-form t) (values new-form expanded))))) (frob form nil))) + +(defun compiler-macro-function (name &optional env) + "If NAME names a compiler-macro in ENV, return the expansion function, else +return NIL. Can be set with SETF when ENV is NIL." + (legal-fun-name-or-type-error name) + ;; CLHS 3.2.2.1: Creating a lexical binding for the function name + ;; not only creates a new local function or macro definition, but + ;; also shadows[2] the compiler macro. + (unless (sb-c::fun-locally-defined-p name env) + ;; Note: CMU CL used to return NIL here when a NOTINLINE + ;; declaration was in force. That's fairly logical, given the + ;; specified effect of NOTINLINE declarations on compiler-macro + ;; expansion. However, (1) it doesn't seem to be consistent with + ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would + ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION + ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So + ;; we don't do it. + (values (info :function :compiler-macro-function name)))) + +;;; FIXME: we don't generate redefinition warnings for these. +(defun (setf compiler-macro-function) (function name &optional env) + (declare (type (or symbol list) name) + (type (or function null) function)) + (when env + ;; ANSI says this operation is undefined. + (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL")) + (when (eq (info :function :kind name) :special-form) + (error "~S names a special form." name)) + (with-single-package-locked-error + (:symbol name "setting the compiler-macro-function of ~A") + (setf (info :function :compiler-macro-function name) function) + function)) diff -Nru sbcl-2.1.1/src/code/macros.lisp sbcl-2.1.11/src/code/macros.lisp --- sbcl-2.1.1/src/code/macros.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,7 +12,29 @@ (in-package "SB-IMPL") -;;;; Destructing-bind +;;;; DEFMACRO + +;;; Inform the cross-compiler how to expand SB-XC:DEFMACRO (= DEFMACRO) +;;; and supporting macros using the already defined host macros until +;;; this file is itself cross-compiled. +#+sb-xc-host +(flet ((defmacro-using-host-expander (name) + (setf (macro-function name) + (lambda (form env) + (declare (ignore env)) + ;; Since SB-KERNEL:LEXENV isn't compatible with the host, + ;; just pass NIL. The expansion correctly captures a non-null + ;; environment, but the expander doesn't need it. + (funcall (cl:macro-function name) form nil))))) + (defmacro-using-host-expander 'sb-xc:defmacro) + (defmacro-using-host-expander 'named-ds-bind) + (defmacro-using-host-expander 'binding*) + (defmacro-using-host-expander 'sb-xc:deftype) + ;; FIXME: POLICY doesn't support DEFMACRO, but we need it ASAP. + (defmacro-using-host-expander 'sb-c:policy)) + + +;;;; Destructuring-bind (sb-xc:defmacro destructuring-bind (lambda-list expression &body body &environment env) @@ -130,10 +152,7 @@ (sb-c:%compiler-defun ',name t ,inline-thing ,extra-info)) ,(if (block-compilation-non-entry-point name) `(progn - ;; Tell the compiler to convert the lambda without - ;; referencing it, so no stray reference stays around - ;; and find-initial-dfo works correctly. - (sb-c::%fun-name-leaf ,named-lambda) + (sb-c::%refless-defun ,named-lambda) ',name) `(%defun ',name ,named-lambda ,@(when (or inline-thing extra-info) `(,inline-thing)) @@ -175,15 +194,14 @@ third argument is an optional documentation string for the variable." (check-designator name defconstant) `(eval-when (:compile-toplevel :load-toplevel :execute) - (sb-c::%defconstant ',name ,value (sb-c:source-location) - ,@(and docp `(',doc))))) + (%defconstant ',name ,value (sb-c:source-location) + ,@(and docp `(',doc))))) (declaim (ftype (sfunction (symbol t &optional t t) null) about-to-modify-symbol-value)) ;;; the guts of DEFCONSTANT - -(defun sb-c::%defconstant (name value source-location &optional (doc nil docp)) +(defun %defconstant (name value source-location &optional (doc nil docp)) #+sb-xc-host (declare (ignore doc docp)) (unless (symbolp name) (error "The constant name is not a symbol: ~S" name)) @@ -221,7 +239,7 @@ :new-value value)) (declare (ignore ignore)) (when aborted - (return-from sb-c::%defconstant name)))))) + (return-from %defconstant name)))))) (warn "redefining a MAKUNBOUND constant: ~S" name))) (:unknown ;; (This is OK -- undefined variables are of this kind. So we @@ -240,6 +258,16 @@ (when docp (setf (documentation name 'variable) doc)) (%set-symbol-value name value)) + ;; Record the names of hairy defconstants when block compiling. + (when (and sb-c::*compile-time-eval* + (eq (sb-c::block-compile sb-c::*compilation*) t)) + (unless (sb-xc:typep value '(or fixnum character symbol)) + (push name sb-c::*hairy-defconstants*))) + ;; Define the constant in the cross-compilation host, since the + ;; value is used when cross-compiling for :COMPILE-TOPLEVEL contexts + ;; which reference the constant. + #+sb-xc-host + (eval `(defconstant ,name ',value)) (setf (info :variable :kind name) :constant) name) @@ -283,7 +311,7 @@ `(',doc))))) (defun %compiler-defglobal (name always-boundp assign-it-p value) - (sb-xc:proclaim `(global ,name)) + (proclaim `(global ,name)) (when assign-it-p (set-symbol-global-value name value)) (sb-c::process-variable-declaration @@ -294,7 +322,7 @@ always-boundp))) (defun %compiler-defvar (var) - (sb-xc:proclaim `(special ,var))) + (proclaim `(special ,var))) ;;;; various conditional constructs @@ -637,11 +665,13 @@ (let ((def (make-macro-lambda (sb-c::debug-name 'compiler-macro name) lambda-list body 'define-compiler-macro name :accessor 'sb-c::compiler-macro-args))) + ;; FIXME: Shouldn't compiler macros also get source locations? + ;; Plain DEFMACRO supplies source location information. `(progn - (eval-when (:compile-toplevel) - (sb-c::%compiler-defmacro :compiler-macro-function ',name)) - (eval-when (:compile-toplevel :load-toplevel :execute) - (sb-c::%define-compiler-macro ',name ,def))))) + (eval-when (:compile-toplevel) + (sb-c::%compiler-defmacro :compiler-macro-function ',name)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (sb-c::%define-compiler-macro ',name ,def))))) (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun sb-c::%define-compiler-macro (name definition) @@ -866,68 +896,57 @@ (values score1 answer1) ; not improved (values score2 answer2))))))))) ; 2 bytes = better -;;; TODO: see if it's possible to not use SXHASH on layouts here. -;;; (etypecase x -;;; ((or named-type numeric-type member-type classoid ..) something) -;;; -> (SB-IMPL::%SEALED-STRUCT-TYPECASE-INDEX -;;; ((named-type numeric-type member-type classoid ...)CHARACTER-SET-TYPE -;;; -> (LET* ((ARRAY -;;; #(4048 NIL NIL NIL NIL NIL -;;; ((# . 1)) NIL -;;; ((# . 1)) NIL NIL -;;; (defun build-sealed-struct-typecase-map (type-unions) (let* ((layout-lists (mapcar (lambda (x) (mapcar #'find-layout x)) type-unions)) (byte (nth-value 1 (pick-best-sxhash-bits (apply #'append layout-lists) - #'layout-clos-hash 1))) - (bin-count (ash 1 (byte-size byte))) - (array (make-array (1+ bin-count) :initial-element nil)) - (mask (1- bin-count)) + #'wrapper-clos-hash 1))) + (array (make-array (ash 1 (byte-size byte)) :initial-element nil)) + (perfectp t) (seen)) - (setf (aref array 0) (logior (ash mask 6) (byte-position byte))) (loop for layout-list in layout-lists - for i from 1 + for selector from 1 do (dolist (layout layout-list) (unless (member layout seen) ; in case of dups / overlaps (push layout seen) - (let ((bin (1+ (logand (ash (layout-clos-hash layout) - (- (the (mod #.sb-vm:n-word-bits) - (byte-position byte)))) - (the (and fixnum unsigned-byte) mask))))) + (let ((bin (ldb byte (wrapper-clos-hash layout)))) + (when (aref array bin) + (setq perfectp nil)) (setf (aref array bin) - (nconc (aref array bin) (list (cons layout i)))))))) - array)) + (nconc (aref array bin) (list (cons layout selector)))))))) + (values `(byte ,(byte-size byte) ,(byte-position byte)) + perfectp + (if perfectp + ;; at most one element is in each bin + (let ((result (make-array (* (length array) 2) :initial-element 0))) + (dotimes (index (length array) result) + (awhen (aref array index) + (setf (aref result index) (caar it) + (aref result (+ index (length array))) (cdar it))))) + array)))) -;;; FIXME: now that structure classoid hashes are computable at compile-time, -;;; we can do ever better in this expander: if the hash is perfect, -;;; then do not iterate over candidates, just flatten the array into -;;; #( case-index # case-index ...) -;;; then test for a hit on the indexed layout, get the case-index, and jump. (sb-xc:defmacro %sealed-struct-typecase-index (cases object) - `(if (%instancep ,object) - (locally (declare (optimize (safety 0))) - ;; When the second argument to LOAD-TIME-VALUE is T in COMPILE (but not COMPILE-FILE) - ;; then element 0 of the vector is used as a compile-time constant and we'll wire in - ;; the shift and mask which produces an even better instruction sequence. - ;; This is pretty awesome and I did not know that we would do that. - (let* ((array ,(build-sealed-struct-typecase-map cases)) - (layout (%instance-layout ,object)) - (hash-spec (the fixnum (svref array 0))) - (shift (ldb (byte ,(integer-length (1- sb-vm:n-word-bits)) 0) - hash-spec))) + (binding* (((byte perfectp cells) (build-sealed-struct-typecase-map cases)) + (n-pairs (/ (length cells) 2))) + `(if (not (%instancep ,object)) + 0 + (let* ((layout (%instance-layout ,object)) + (index (ldb ,byte (layout-clos-hash layout))) + ;; Compare by WRAPPER, not LAYOUT. LAYOUTs can't go in a simple-vector. + (wrapper (layout-friend layout)) + (cells ,cells)) + (declare (optimize (safety 0))) (the (mod ,(1+ (length cases))) - ;; DOLIST performs a leading test, but we're OK with a cell - ;; that is NIL. It'll miss and then exit at the end of the loop. - ;; This potentially avoids one comparison vs NIL if we hit immediately. - (let ((list (svref array - (1+ (logand (ash (layout-clos-hash layout) (- shift)) - (ash hash-spec -6)))))) - (loop (let ((cell (car list))) - (cond ((eq layout (car cell)) (return (cdr cell))) - ((null (setq list (cdr list))) (return 0))))))))) - 0)) + ,(if perfectp + `(if (eq (aref cells index) wrapper) (aref cells (+ index ,n-pairs)) 0) + ;; DOLIST performs a leading test, but we're OK with a cell + ;; that is NIL. It'll miss and then exit at the end of the loop. + ;; This potentially avoids one comparison vs NIL if we hit immediately. + `(let ((list (svref cells index))) + (loop (let ((cell (car list))) + (cond ((eq wrapper (car cell)) (return (cdr cell))) + ((null (setq list (cdr list))) (return 0)))))))))))) ;;; Given an arbitrary TYPECASE, see if it is a discriminator over ;;; an assortment of structure-object subtypes. If it is, potentially turn it @@ -947,12 +966,18 @@ ;;; for a match on both the hash and the layout. (defun expand-struct-typecase (keyform temp normal-clauses type-specs default errorp &aux (n-root-types 0) (exhaustive-list)) - (flet ((discover-subtypes (specifier) + (labels + ((ok-classoid (classoid) + (or (structure-classoid-p classoid) + (and (sb-kernel::built-in-classoid-p classoid) + (not (memq (classoid-name classoid) + sb-kernel::**non-instance-classoid-types**))))) + (discover-subtypes (specifier) (let* ((parse (specifier-type specifier)) (worklist - (cond ((structure-classoid-p parse) (list parse)) + (cond ((ok-classoid parse) (list parse)) ((and (union-type-p parse) - (every #'structure-classoid-p (union-type-types parse))) + (every #'ok-classoid (union-type-types parse))) (copy-list (union-type-types parse))) (t (return-from discover-subtypes nil))))) @@ -965,12 +990,11 @@ (loop (unless worklist (return)) (let ((classoid (pop worklist))) (visited classoid) - (awhen (classoid-subclasses classoid) - (dohash ((classoid layout) it) - (declare (ignore layout)) - (unless (or (member classoid (visited)) - (member classoid worklist)) - (setf worklist (nconc worklist (list classoid)))))))) + (sb-kernel::do-subclassoids ((subclassoid wrapper) classoid) + (declare (ignore wrapper)) + (unless (or (member subclassoid (visited)) + (member subclassoid worklist)) + (setf worklist (nconc worklist (list subclassoid))))))) (setf exhaustive-list (union (visited) exhaustive-list)) (visited))))) (let ((classoid-lists (mapcar #'discover-subtypes type-specs))) @@ -1123,7 +1147,7 @@ ;; every consequent is trivial. (when (= maxprobes 1) (block try-table-lookup - (let ((values (make-array (length bins))) + (let ((values (make-array (length bins) :initial-element 0)) (single-value) ; only if exactly one clause (types nil)) (dolist (clause clauses) @@ -1425,23 +1449,18 @@ errorp proceedp expected-type) (when proceedp ; CCASE or CTYPECASE (return-from case-body-aux - (let ((block (gensym)) - (again (gensym))) - `(let ((,keyform-value ,keyform)) - (block ,block - (tagbody - ,again - (return-from - ,block - (cond ,@(nreverse clauses) - (t - (setf ,keyform-value - (setf ,keyform - (case-body-error - ',name ',keyform ,keyform-value - ',expected-type ',keys))) - (go ,again)))))))))) - + ;; It is not a requirement to evaluate subforms of KEYFORM once only, but it often + ;; reduces code size to do so, as the update form will take advantage of typechecks + ;; already performed. (Nor is it _required_ to re-evaluate subforms) + (binding* ((switch (make-symbol "SWITCH")) + (retry + ;; TODO: consider using the union type simplifier algorithm here + `(case-body-error ',name ',keyform ,keyform-value ',expected-type ',keys)) + ((vars vals stores writer reader) (get-setf-expansion keyform))) + `(let* ,(mapcar #'list vars vals) + (named-let ,switch ((,keyform-value ,reader)) + (cond ,@(nreverse clauses) + (t (multiple-value-bind ,stores ,retry (,switch ,writer))))))))) (let ((implement-as name) (original-keys keys)) (when (member name '(typecase etypecase)) @@ -1497,10 +1516,33 @@ (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T)) (cond ,@(nreverse clauses) ,@(when errorp - `((t (,(ecase name - (etypecase 'etypecase-failure) - (ecase 'ecase-failure)) - ,keyform-value ',original-keys)))))))) + `((t ,(ecase name + (etypecase + `(etypecase-failure + ,keyform-value ,(etypecase-error-spec original-keys))) + (ecase + `(ecase-failure ,keyform-value ',original-keys)))))))))) + +;;; ETYPECASE over clauses that form a "simpler" type specifier should use that, +;;; e.g. partitions of INTEGER: +;;; (etypecase ((integer * -1) ...) ((eql 0) ...) ((integer 1 *) ...)) +;;; (etypecase (fixnum ...) (bignum ...)) +(defun etypecase-error-spec (types) + (when (cdr types) ; no sense in doing this for a single type + (let ((parsed (mapcar #'sb-c::careful-specifier-type types))) + (when (every (lambda (x) (and x (not (contains-unknown-type-p x)))) + parsed) + (let* ((union (apply #'type-union parsed)) + (unparsed (type-specifier union))) + ;; If the type-union of the types is a simpler expression than (OR ...), + ;; then return the simpler one. CTYPECASE could do this also, but doesn't. + ;; http://www.lispworks.com/documentation/HyperSpec/Body/m_tpcase.htm#etypecase + ;; "If no normal-clause matches, a non-correctable error of type type-error + ;; is signaled. The offending datum is the test-key and the expected type + ;; is /type equivalent/ to (or type1 type2 ...)" + (when (symbolp unparsed) + (return-from etypecase-error-spec `',unparsed)))))) + `',types) (sb-xc:defmacro case (keyform &body cases) "CASE Keyform {({(Key*) | Key} Form*)}* @@ -1822,3 +1864,419 @@ (declare (ignorable ,var)) ,@body) (get-output-stream-string ,dummy))))) + + +;;;; COMPARE-AND-SWAP +;;;; +;;;; SB-EXT:COMPARE-AND-SWAP is the public API for now. +;;;; +;;;; Internally our interface has CAS, GET-CAS-EXPANSION, +;;;; DEFCAS, and #'(CAS ...) functions. + +(defun expand-structure-slot-cas (info name place) + (let* ((dd (car info)) + (structure (dd-name dd)) + (slotd (cdr info)) + (index (dsd-index slotd)) + (type (dsd-type slotd)) + (casser + (case (dsd-raw-type slotd) + ((t) '%instance-cas) + #+(or arm64 ppc ppc64 riscv x86 x86-64) + ((word) '%raw-instance-cas/word) + #+riscv + ((signed-word) '%raw-instance-cas/signed-word)))) + (unless casser + (error "Cannot use COMPARE-AND-SWAP with structure accessor ~ + for a typed slot: ~S" + place)) + (when (dsd-read-only slotd) + (error "Cannot use COMPARE-AND-SWAP with structure accessor ~ + for a read-only slot: ~S" + place)) + (destructuring-bind (op arg) place + (aver (eq op name)) + (with-unique-names (instance old new) + (values (list instance) + (list `(the ,structure ,arg)) + old + new + `(truly-the (values ,type &optional) + (,casser ,instance ,index + (the ,type ,old) + (the ,type ,new))) + `(,op ,instance)))))) + +;;; FIXME: remove (it's EXPERIMENTAL, so doesn't need to go through deprecation) +(defun get-cas-expansion (place &optional environment) + "Analogous to GET-SETF-EXPANSION. Returns the following six values: + + * list of temporary variables + + * list of value-forms whose results those variable must be bound + + * temporary variable for the old value of PLACE + + * temporary variable for the new value of PLACE + + * form using the aforementioned temporaries which performs the + compare-and-swap operation on PLACE + + * form using the aforementioned temporaries with which to perform a volatile + read of PLACE + +Example: + + (get-cas-expansion '(car x)) + ; => (#:CONS871), (X), #:OLD872, #:NEW873, + ; (SB-KERNEL:%COMPARE-AND-SWAP-CAR #:CONS871 #:OLD872 :NEW873). + ; (CAR #:CONS871) + + (defmacro my-atomic-incf (place &optional (delta 1) &environment env) + (multiple-value-bind (vars vals old new cas-form read-form) + (get-cas-expansion place env) + (let ((delta-value (gensym \"DELTA\"))) + `(let* (,@(mapcar 'list vars vals) + (,old ,read-form) + (,delta-value ,delta) + (,new (+ ,old ,delta-value))) + (loop until (eq ,old (setf ,old ,cas-form)) + do (setf ,new (+ ,old ,delta-value))) + ,new)))) + +EXPERIMENTAL: Interface subject to change." + ;; FIXME: this seems wrong on two points: + ;; 1. if TRULY-THE had a CAS expander (which it doesn't) we'd want + ;; to use %MACROEXPAND[-1] so as not to lose the "truly-the"-ness + ;; 2. if both a CAS expander and a macro exist, the CAS expander + ;; should be preferred before macroexpanding (just like SETF does) + (let ((expanded (macroexpand place environment))) + (flet ((invalid-place () + (error "Invalid place to CAS: ~S -> ~S" place expanded))) + (unless (consp expanded) + (cond ((and (symbolp expanded) + (member (info :variable :kind expanded) + '(:global :special))) + (setq expanded `(symbol-value ',expanded))) + (t + (invalid-place)))) + (let ((name (car expanded))) + (unless (symbolp name) + (invalid-place)) + (acond + ((info :cas :expander name) + ;; CAS expander. + (funcall it expanded environment)) + + ;; Structure accessor + ((structure-instance-accessor-p name) + (expand-structure-slot-cas it name expanded)) + + ;; CAS function + (t + (with-unique-names (old new) + (let ((vars nil) + (vals nil) + (args nil)) + (dolist (x (reverse (cdr expanded))) + (cond ((constantp x environment) + (push x args)) + (t + (let ((tmp (gensymify x))) + (push tmp args) + (push tmp vars) + (push x vals))))) + (values vars vals old new + `(funcall #'(cas ,name) ,old ,new ,@args) + `(,name ,@args)))))))))) + + +;;; This is what it all comes down to. +(sb-xc:defmacro cas (place old new &environment env) + "Synonym for COMPARE-AND-SWAP. + +Additionally DEFUN, DEFGENERIC, DEFMETHOD, FLET, and LABELS can be also used to +define CAS-functions analogously to SETF-functions: + + (defvar *foo* nil) + + (defun (cas foo) (old new) + (cas (symbol-value '*foo*) old new)) + +First argument of a CAS function is the expected old value, and the second +argument of is the new value. Note that the system provides no automatic +atomicity for CAS functions, nor can it verify that they are atomic: it is up +to the implementor of a CAS function to ensure its atomicity. + +EXPERIMENTAL: Interface subject to change." + ;; It's not necessary that GET-CAS-EXPANSION work on defined alien vars. + ;; They're not generalized places in the sense that they could hold any object, + ;; so there's very little point to being more general. + ;; In particular, allowing ATOMIC-PUSH or ATOMIC-POP on them is wrong. + (awhen (and (symbolp place) + (eq (info :variable :kind place) :alien) + (sb-alien::cas-alien place old new)) + (return-from cas it)) + (multiple-value-bind (temps place-args old-temp new-temp cas-form) + (get-cas-expansion place env) + `(let* (,@(mapcar #'list temps place-args) + (,old-temp ,old) + (,new-temp ,new)) + ,cas-form))) + +(sb-xc:defmacro compare-and-swap (place old new) + "Atomically stores NEW in PLACE if OLD matches the current value of PLACE. +Two values are considered to match if they are EQ. Returns the previous value +of PLACE: if the returned value is EQ to OLD, the swap was carried out. + +PLACE must be an CAS-able place. Built-in CAS-able places are accessor forms +whose CAR is one of the following: + + CAR, CDR, FIRST, REST, SVREF, SYMBOL-PLIST, SYMBOL-VALUE, SVREF, SLOT-VALUE + SB-MOP:STANDARD-INSTANCE-ACCESS, SB-MOP:FUNCALLABLE-STANDARD-INSTANCE-ACCESS, + +or the name of a DEFSTRUCT created accessor for a slot whose storage type +is not raw. (Refer to the the \"Efficiency\" chapter of the manual +for the list of raw slot types. Future extensions to this macro may allow +it to work on some raw slot types.) + +In case of SLOT-VALUE, if the slot is unbound, SLOT-UNBOUND is called unless +OLD is EQ to SB-PCL:+SLOT-UNBOUND+ in which case SB-PCL:+SLOT-UNBOUND+ is +returned and NEW is assigned to the slot. Additionally, the results are +unspecified if there is an applicable method on either +SB-MOP:SLOT-VALUE-USING-CLASS, (SETF SB-MOP:SLOT-VALUE-USING-CLASS), or +SB-MOP:SLOT-BOUNDP-USING-CLASS. + +Additionally, the PLACE can be a anything for which a CAS-function has +been defined. (See SB-EXT:CAS for more information.) +" + `(cas ,place ,old ,new)) + + +;;;; ATOMIC-INCF and ATOMIC-DECF + +(defun expand-atomic-frob + (name specified-place diff env + &aux (place (macroexpand specified-place env))) + (declare (type (member atomic-incf atomic-decf) name)) + (flet ((invalid-place () + (error "Invalid first argument to ~S: ~S" name specified-place)) + (compute-newval (old) ; used only if no atomic inc vop + `(logand (,(case name (atomic-incf '+) (atomic-decf '-)) ,old + (the sb-vm:signed-word ,diff)) sb-ext:most-positive-word)) + (compute-delta () ; used only with atomic inc vop + `(logand ,(case name + (atomic-incf `(the sb-vm:signed-word ,diff)) + (atomic-decf `(- (the sb-vm:signed-word ,diff)))) + sb-ext:most-positive-word))) + (declare (ignorable #'compute-newval #'compute-delta)) + (when (and (symbolp place) + (eq (info :variable :kind place) :global) + (type= (info :variable :type place) (specifier-type 'fixnum))) + ;; Global can't be lexically rebound. + (return-from expand-atomic-frob + `(truly-the fixnum (,(case name + (atomic-incf '%atomic-inc-symbol-global-value) + (atomic-decf '%atomic-dec-symbol-global-value)) + ',place (the fixnum ,diff))))) + (unless (consp place) (invalid-place)) + (destructuring-bind (op . args) place + ;; FIXME: The lexical environment should not be disregarded. + ;; CL builtins can't be lexically rebound, but structure accessors can. + (case op + (aref + (unless (singleton-p (cdr args)) + (invalid-place)) + (with-unique-names (array) + `(let ((,array (the (simple-array word (*)) ,(car args)))) + #+compare-and-swap-vops + (%array-atomic-incf/word + ,array + (check-bound ,array (array-dimension ,array 0) ,(cadr args)) + ,(compute-delta)) + #-compare-and-swap-vops + ,(with-unique-names (index old-value) + `(without-interrupts + (let* ((,index ,(cadr args)) + (,old-value (aref ,array ,index))) + (setf (aref ,array ,index) ,(compute-newval old-value)) + ,old-value)))))) + ((car cdr first rest) + (when (cdr args) + (invalid-place)) + `(truly-the + fixnum + (,(case op + ((first car) (case name + (atomic-incf '%atomic-inc-car) + (atomic-decf '%atomic-dec-car))) + ((rest cdr) (case name + (atomic-incf '%atomic-inc-cdr) + (atomic-decf '%atomic-dec-cdr)))) + ,(car args) (the fixnum ,diff)))) + (t + (when (or (cdr args) + ;; Because accessor info is identical for the writer and reader + ;; functions, without a SYMBOLP check this would erroneously allow + ;; (ATOMIC-INCF ((SETF STRUCT-SLOT) x)) + (not (symbolp op)) + (not (structure-instance-accessor-p op))) + (invalid-place)) + (let* ((accessor-info (structure-instance-accessor-p op)) + (slotd (cdr accessor-info)) + (type (dsd-type slotd))) + (unless (and (eq 'sb-vm:word (dsd-raw-type slotd)) + (type= (specifier-type type) (specifier-type 'sb-vm:word))) + (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S" + name sb-vm:n-word-bits type place)) + (when (dsd-read-only slotd) + (error "Cannot use ~S with structure accessor for a read-only slot: ~S" + name place)) + #+compare-and-swap-vops + `(truly-the sb-vm:word + (%raw-instance-atomic-incf/word + (the ,(dd-name (car accessor-info)) ,@args) + ,(dsd-index slotd) + ,(compute-delta))) + #-compare-and-swap-vops + (with-unique-names (structure old-value) + `(without-interrupts + (let* ((,structure ,@args) + (,old-value (,op ,structure))) + (setf (,op ,structure) ,(compute-newval old-value)) + ,old-value))))))))) + +(sb-xc:defmacro atomic-incf (&environment env place &optional (diff 1)) + #.(format nil + "Atomically increments PLACE by DIFF, and returns the value of PLACE before +the increment. + +PLACE must access one of the following: + - a DEFSTRUCT slot with declared type (UNSIGNED-BYTE ~D~:*) + or AREF of a (SIMPLE-ARRAY (UNSIGNED-BYTE ~D~:*) (*)) + The type SB-EXT:WORD can be used for these purposes. + - CAR or CDR (respectively FIRST or REST) of a CONS. + - a variable defined using DEFGLOBAL with a proclaimed type of FIXNUM. +Macroexpansion is performed on PLACE before expanding ATOMIC-INCF. + +Incrementing is done using modular arithmetic, +which is well-defined over two different domains: + - For structures and arrays, the operation accepts and produces + an (UNSIGNED-BYTE ~D~:*), and DIFF must be of type (SIGNED-BYTE ~D). + ATOMIC-INCF of #x~x by one results in #x0 being stored in PLACE. + - For other places, the domain is FIXNUM, and DIFF must be a FIXNUM. + ATOMIC-INCF of #x~x by one results in #x~x + being stored in PLACE. + +DIFF defaults to 1. + +EXPERIMENTAL: Interface subject to change." + sb-vm:n-word-bits most-positive-word + most-positive-fixnum most-negative-fixnum) + (expand-atomic-frob 'atomic-incf place diff env)) + +(sb-xc:defmacro atomic-decf (&environment env place &optional (diff 1)) + #.(format nil + "Atomically decrements PLACE by DIFF, and returns the value of PLACE before +the decrement. + +PLACE must access one of the following: + - a DEFSTRUCT slot with declared type (UNSIGNED-BYTE ~D~:*) + or AREF of a (SIMPLE-ARRAY (UNSIGNED-BYTE ~D~:*) (*)) + The type SB-EXT:WORD can be used for these purposes. + - CAR or CDR (respectively FIRST or REST) of a CONS. + - a variable defined using DEFGLOBAL with a proclaimed type of FIXNUM. +Macroexpansion is performed on PLACE before expanding ATOMIC-DECF. + +Decrementing is done using modular arithmetic, +which is well-defined over two different domains: + - For structures and arrays, the operation accepts and produces + an (UNSIGNED-BYTE ~D~:*), and DIFF must be of type (SIGNED-BYTE ~D). + ATOMIC-DECF of #x0 by one results in #x~x being stored in PLACE. + - For other places, the domain is FIXNUM, and DIFF must be a FIXNUM. + ATOMIC-DECF of #x~x by one results in #x~x + being stored in PLACE. + +DIFF defaults to 1. + +EXPERIMENTAL: Interface subject to change." + sb-vm:n-word-bits most-positive-word + most-negative-fixnum most-positive-fixnum) + (expand-atomic-frob 'atomic-decf place diff env)) + +(sb-xc:defmacro atomic-update (place update-fn &rest arguments &environment env) + "Updates PLACE atomically to the value returned by calling function +designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE. + +PLACE may be read and UPDATE-FN evaluated and called multiple times before the +update succeeds: atomicity in this context means that the value of PLACE did +not change between the time it was read, and the time it was replaced with the +computed value. + +PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP. + +Examples: + + ;;; Conses T to the head of FOO-LIST. + (defstruct foo list) + (defvar *foo* (make-foo)) + (atomic-update (foo-list *foo*) #'cons t) + + (let ((x (cons :count 0))) + (mapc #'sb-thread:join-thread + (loop repeat 1000 + collect (sb-thread:make-thread + (lambda () + (loop repeat 1000 + do (atomic-update (cdr x) #'1+) + (sleep 0.00001)))))) + ;; Guaranteed to be (:COUNT . 1000000) -- if you replace + ;; atomic update with (INCF (CDR X)) above, the result becomes + ;; unpredictable. + x) +" + (multiple-value-bind (vars vals old new cas-form read-form) + (get-cas-expansion place env) + `(let* (,@(mapcar 'list vars vals) + (,old ,read-form)) + (loop for ,new = (funcall ,update-fn ,@arguments ,old) + until (eq ,old (setf ,old ,cas-form)) + finally (return ,new))))) + +(sb-xc:defmacro atomic-push (obj place &environment env) + "Like PUSH, but atomic. PLACE may be read multiple times before +the operation completes -- the write does not occur until such time +that no other thread modified PLACE between the read and the write. + +Works on all CASable places." + (multiple-value-bind (vars vals old new cas-form read-form) + (get-cas-expansion place env) + `(let* (,@(mapcar 'list vars vals) + (,old ,read-form) + (,new (cons ,obj ,old))) + (loop until (eq ,old (setf ,old ,cas-form)) + do (setf (cdr ,new) ,old) + finally (return ,new))))) + +(sb-xc:defmacro atomic-pop (place &environment env) + "Like POP, but atomic. PLACE may be read multiple times before +the operation completes -- the write does not occur until such time +that no other thread modified PLACE between the read and the write. + +Works on all CASable places." + (multiple-value-bind (vars vals old new cas-form read-form) + (get-cas-expansion place env) + `(let* (,@(mapcar 'list vars vals) + (,old ,read-form)) + (loop (let ((,new (cdr ,old))) + (when (eq ,old (setf ,old ,cas-form)) + (return (car (truly-the list ,old))))))))) + +#-metaspace +(progn +(sb-xc:defmacro wrapper-friend (x) x) +(sb-xc:defmacro layout-friend (x) x) +(sb-xc:defmacro layout-clos-hash (x) `(wrapper-clos-hash ,x)) +#-64-bit (sb-xc:defmacro layout-depthoid (x) `(wrapper-depthoid ,x)) +(sb-xc:defmacro layout-flags (x) `(wrapper-flags ,x)) +) diff -Nru sbcl-2.1.1/src/code/maphash.lisp sbcl-2.1.11/src/code/maphash.lisp --- sbcl-2.1.1/src/code/maphash.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/maphash.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -138,6 +138,9 @@ (defconstant hash-table-weak-flag 8) (defconstant hash-table-finalizer-flag 4) +;;; USERFUN-FLAG implies a nonstandard hash function. Such tables may also have +;;; a custom comparator. But you can't have a custom comparator without a custom +;;; hash, because there's no way in general to produce a compatible hash. (defconstant hash-table-userfun-flag 2) (defconstant hash-table-synchronized-flag 1) diff -Nru sbcl-2.1.1/src/code/metaspace.lisp sbcl-2.1.11/src/code/metaspace.lisp --- sbcl-2.1.1/src/code/metaspace.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/code/metaspace.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,370 @@ +;;;; Allocator for LAYOUTs in the metadata space a/k/a "metaspace". +;;;; These objects are manually allocated and freed. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-VM") + +;; A slab "size class" holds any object of that size or smaller. +(defconstant-eqx chunk-size-classes ; measured in lispwords + #.(sb-xc:make-array 8 :initial-contents '(0 8 12 16 24 32 48 64) + :element-type '(unsigned-byte 16)) + #'equalp) + +;;; The most common layout size is just 8 words: +;;; word 0: header +;;; word 1: wrapper +;;; word 2: clos hash +;;; word 3: flags +;;; word 4..6 : ID vector +;;; word 7: bitmap +;;; Thus the smallest size the slab allocator can dole out is 8 words. + +;; The largest size class nust not exceed the physical size of the slab, +;; counting the fixed overhead of 4 words. +;; nwords | capacity | used | waste +;; | | (bytes) +;; --------+----------+--------------- +;; 8 | 31 | 2016 | 32 +;; 12 | 21 | 2048 | 0 +;; 16 | 15 | 1952 | 96 +;; 24 | 10 | 1952 | 96 +;; 32 | 7 | 1824 | 224 +;; 48 | 5 | 1952 | 96 +;; 64 | 3 | 1472 | 480 +;; "Waste" = slab size - overhead - (chunk_size_in_bytes * capacity). + +(defun chunk-nwords-to-sizeclass-index (nwords) + (let ((classes chunk-size-classes)) + (loop for i from 1 below (length classes) + when (<= nwords (aref classes i)) + do (return i) + finally (error "Oversized chunk: ~D words" nwords)))) + +(defun metaspace-sizeclass->nbytes (sizeclass) + (* (aref chunk-size-classes sizeclass) n-word-bytes)) + +(define-load-time-global *metaspace-freelists* (make-array 8 :element-type 'word :initial-element 0)) +(declaim (type (simple-array word (8)) *metaspace-freelists*)) + +;;; A completely empty slab is put back in this list for reuse, +;;; and a different chunk size can be chosen for it when next used. +;;; This is a singly-linked list threaded through SLAB-NEXT. +(defmacro metaspace-slab-recycler () '(aref *metaspace-freelists* 0)) + +;;; A list of memory ranges obtained directly from os_allocate. +;;; A tract is represented by a pointer to its start and a pointer +;;; to the highest address not yet used. Slabs are allocated downwards, +;;; so that when the start and the in-use pointer of a tract collide, +;;; the tract is full. +;;; In typical usage, there will be exactly 1 tract. This is enough room +;;; to hold approximately 32768 instances of LAYOUT, depending on the +;;; size of the layouts stored. It is unlikely that more room would be +;;; needed, but it does work to have a variable number of tracts. +;;; +;;; If at some point we ever figure out how to make both the static space +;;; and metaspace relocatable, and we permanently wire a CPU register to point +;;; to the boundary between the spaces, then the fact that metaspace grows +;;; downward will be halpful in as much as the register will be able to access +;;; a certain amount of either space using small positive or negative offsets. +;;; +;;; Tract: #(base free end next-tract) +(define-load-time-global *metaspace-tracts* nil) +(defmacro tract-base (tract) + `(aref (truly-the (simple-array word (4)) ,tract) 0)) +(defmacro tract-current (tract) + `(aref (truly-the (simple-array word (4)) ,tract) 1)) +(defmacro tract-end (tract) + `(aref (truly-the (simple-array word (4)) ,tract) 2)) + +(defmacro do-tracts ((var) &body body) + `(let ((,var *metaspace-tracts*)) + ;; no iteration yet + ,@body)) + +;;; Try to place a tract just below the readonly space, which we know to be +;;; at a good sub-2GiB address that works for the architecture and OS. +;;; TODO: if multiple tracts exist and were allocated consecutively, +;;; can we coalesce them? +(defun os-allocate-metaspace-tract () + (error "Can't allocate new metaspace tracts") + #+nil + (let* ((request (- (if (null *metaspace-tracts*) + sb-vm:read-only-space-start + (reduce #'min *metaspace-tracts* + :key (lambda (x) (sap-int (car x))))) + metaspace-tract-size)) + (actual (alien-funcall + (extern-alien "os_validate" (function system-area-pointer int unsigned unsigned)) + #+linux 3 ; movable | MAP_32BIT + #-linux 1 ; movable + request metaspace-tract-size))) + ;; The tract's representation is (base-address . current-pointer) + (let ((tract (cons actual (sap+ actual metaspace-tract-size)))) + (push tract *metaspace-tracts*) + tract))) + +;;; Grab a slab out of an available tract and assign it a chunk size +;;; which is represented both as bytes and a class index. +(defun new-metaspace-slab (chunk-size-bytes sizeclass) + (let ((slab (int-sap (metaspace-slab-recycler)))) + (if (/= (sap-int slab) 0) + (setf (metaspace-slab-recycler) (sap-int (slab-next slab))) + (let ((tract *metaspace-tracts*)) + (when (= (tract-base tract) (tract-current tract)) + (setq tract (os-allocate-metaspace-tract))) + ;; Claim some new space from the tract, below CURRENT and above BASE. + (let* ((end (int-sap (tract-current tract))) + (start (sap+ end (- metaspace-slab-size)))) + (setf (tract-current tract) (sap-int start) + slab start)))) + ;; Build a linked list of chunks in the slab. The highest-addressed chunk + ;; in the slab aligns its end to exactly the end of the slab. In this way + ;; any unused bytes can be lumped together with the fixed overhead at the + ;; beginning, versus if the first chunk's start abutted the end of the fixed + ;; words, then there may be unused space at both ends, and so the math + ;; for checking valid pointers would get too messy. + ;; i.e. we need an inquiry operation for "is it a valid chunk?" given any + ;; random bit pattern, and it must be reliable and efficient. + (let* ((chunk-end (sap+ slab metaspace-slab-size)) + (chunk (sap+ chunk-end (- chunk-size-bytes))) ; chunk start + (usable-range-start (slab-usable-range-start slab)) + (capacity 1)) + (setf (sap-ref-word chunk 0) 0) ; terminate the freelist + (loop (let ((previous (sap+ chunk (- chunk-size-bytes)))) + (when (sap< previous usable-range-start) (return)) + (incf capacity) + (setf (sap-ref-sap previous 0) chunk + chunk-end chunk + chunk previous))) + (init-slab-header slab sizeclass chunk-size-bytes capacity) + (setf (slab-freelist slab) chunk) + ;; Insert this as the sole slab for this sizeclass. + ;; A new slab is never allocated if the sizeclass has any slabs + ;; with space available. + (setf (aref *metaspace-freelists* sizeclass) (sap-int slab)) + #+debug (format t "New slab @ ~x, capacity ~d, waste=~Db~% list=~x~%" + slab (slab-capacity slab) + (- metaspace-slab-size + (* slab-overhead-words n-word-bytes) + (* (slab-capacity slab) chunk-size-bytes)) + (slab-freelist-as-list slab)) + slab))) + +(defmacro chunk-used-p (chunk) + `(= (sap-ref-8 ,chunk #+little-endian 0 #+big-endian ,(1- n-word-bytes)) + instance-widetag)) + +;;; A not-in-use chunk is linked through its 0th word, which will never +;;; resemble a lisp object header word. +(defmacro chunk-next (chunk) `(sap-ref-sap ,chunk 0)) + +;;; Test whether ADDRESS is a conservative (ambiguous) root. +;;; This algorithm will need to be in C of course. +(defun valid-metaspace-chunk-p (addr) + (declare (word addr)) + (unless (= (logand addr lowtag-mask) instance-pointer-lowtag) + (return-from valid-metaspace-chunk-p nil)) + (setq addr (logandc2 addr lowtag-mask)) + (do-tracts (tract) + (when (and (>= addr (tract-current tract)) (< addr (tract-end tract))) + ;; Align to containing slab + (let ((slab (int-sap (logandc2 addr (1- metaspace-slab-size))))) + (return-from valid-metaspace-chunk-p + (and (not (zerop (slab-usage slab))) + ;; Chunks are aligned such that the final chunk touches the + ;; final word of the slab. Therefore to find a chunk index + ;; we need to compute the displacement backwards from end. + (multiple-value-bind (index remainder) + (floor (sap- (sap+ slab metaspace-slab-size) (int-sap addr)) + (slab-chunk-size slab)) + (and (zerop remainder) ; correctly aligned + (<= index (slab-capacity slab)) ; within the slab + (chunk-used-p (int-sap addr)))))))))) + +(defun allocate-metaspace-chunk (nwords) + (let ((sizeclass (chunk-nwords-to-sizeclass-index nwords))) + (with-system-mutex (*allocator-mutex*) + (let* ((slab-addr (aref *metaspace-freelists* sizeclass)) + (slab (if (zerop slab-addr) + (new-metaspace-slab (metaspace-sizeclass->nbytes sizeclass) + sizeclass) + (int-sap slab-addr))) + (hole (slab-freelist slab)) + (next-hole (chunk-next hole))) + (aver (/= (sap-int hole) 0)) + (setf (slab-freelist slab) next-hole) + (incf (slab-usage slab)) + (when (= (sap-int next-hole) 0) + ;; Check some invariants - this had to be the head of the list of slabs + ;; for the sizeclass, and it has to be at max capacity. + (aver (= 0 (sap-int (slab-prev slab)))) + (aver (= (slab-usage slab) (slab-capacity slab))) + ;; Remove the slab from the list of slabs that have any + ;; available space for the size class. + (let ((next-slab (slab-next slab))) + (setf (aref *metaspace-freelists* sizeclass) + (cond ((= (sap-int next-slab) 0) + 0) + (t + (setf (slab-next slab) (int-sap 0) + (slab-prev next-slab) (int-sap 0)) + (sap-int next-slab)))))) + ;; Deposit a valid instance header word + (setf (sap-ref-word hole 0) + (logior (ash (1- nwords) (+ sb-vm:n-widetag-bits 2)) + instance-widetag)) + ;; Use the unchecked %MAKE-LISP-obj to return it + (%make-lisp-obj (logior (sap-int hole) instance-pointer-lowtag)))))) + +;;; Address should be an aligned (not tagged) base address of a chunk. +(defun unallocate-metaspace-chunk (address) + (declare (word address)) + #+debug (aver (metaspace-chunk-valid-p address)) + (let* ((slab (int-sap (logandc2 address (1- metaspace-slab-size)))) + (sizeclass (ash (slab-sizeclass slab) (- sb-vm:n-fixnum-tag-bits))) + (size (slab-chunk-size slab))) + (aver (= size (metaspace-sizeclass->nbytes sizeclass))) + ;; Clear the memory + (alien-funcall (extern-alien "memset" (function void unsigned int size-t)) + address 0 size) + (with-system-mutex (*allocator-mutex*) + (let* ((freelist (int-sap (aref *metaspace-freelists* sizeclass))) + (slab-was-partly-available ; true if already in freelist + (or (sap= freelist slab) (/= 0 (sap-int (slab-prev slab))))) + (n-objects (decf (slab-usage slab)))) ; new count + #+debug (format t "~&Hole in slab @ ~x, sizeclass ~D, newcount=~D of ~D~%" + slab sizeclass n-objects (slab-capacity slab)) + ;; If slab has become completely available, add it to the recycle bin. + (when (zerop n-objects) + (when slab-was-partly-available + ;; Capacity 1 can't exist in "partially available" state + (aver (> (slab-capacity slab) 1)) + ;; Remove from size-specific doubly-linked freelist before + ;; adding to recycle bin. + (let ((prev (slab-prev slab)) + (next (slab-next slab))) + ;; prev->next = this->next + (if (= (sap-int prev) 0) ; no previous, was the head of freelist + (setf (aref *metaspace-freelists* sizeclass) (sap-int next)) + (setf (slab-next prev) next)) + ;; next->prev = this->prev + (unless (= (sap-int next) 0) + (setf (slab-prev next) prev)))) + ;; Like (PUSH slab recycler) + (setf (slab-next slab) (int-sap (metaspace-slab-recycler)) + (metaspace-slab-recycler) (sap-int slab)) + ;; Clear out the unused words + (setf (sap-ref-word slab 0) 0 + (slab-prev slab) (int-sap 0) + (slab-freelist slab) (int-sap 0)) + #+debug (format t "~&Slab moved to recycle bin~%") + (return-from unallocate-metaspace-chunk)) + + ;; Slab has some used chunks, and gains an available chunk. + ;; Do like (PUSH address (slab-freelist slab)) + (let ((hole (int-sap address))) + (setf (chunk-next hole) (slab-freelist slab) + (slab-freelist slab) hole)) + + ;; If the slab was not already in the list of partly-available slabs for + ;; its sizeclass, it goes to the head of the respective doubly-linked list. + (unless slab-was-partly-available + #+debug (format t "~&Insert slab in sizeclass freelist~%") + (aver (= (sap-int (slab-prev slab)) 0)) + (setf (slab-next slab) freelist) + (unless (= (sap-int freelist) 0) + (setf (slab-prev freelist) slab)) + (setf (aref *metaspace-freelists* sizeclass) (sap-int slab)))))) + nil) + +;;;; That's the entire allocator. These are for examination of the state. + +(defun slab-freelist-as-list (slab &aux (sap (slab-freelist slab)) result) + (loop (if (sap= sap (int-sap 0)) (return (nreverse result))) + (push (sap-int sap) result) + (setq sap (sap-ref-sap sap 0)))) + +(export 'show-slabs) +(defun show-slabs (&aux (*print-right-margin* 128)) + (do-tracts (tract) + (let ((tract-end (int-sap (tract-end tract))) + (slab (int-sap (tract-current tract)))) + (format t "tract: Begin = ~x Current = ~x End = ~x~%" + (tract-base tract) (sap-int slab) (sap-int tract-end)) + (do ((slab slab (sap+ slab metaspace-slab-size))) + ((sap>= slab tract-end)) + (let ((ptr (sap+ slab metaspace-slab-size)) + (map)) + (dotimes (i (slab-capacity slab)) + (setf ptr (sap+ ptr (- (slab-chunk-size slab)))) + (push (if (chunk-used-p ptr) #\* #\_) map)) + (if (zerop (slab-capacity slab)) + (format t " slab @ ~x: free~%" (sap-int slab)) + (format t " slab @ ~x: cl=~D=~3Db, cap=~d, ct=~2d [~A]~%" + (sap-int slab) + (ash (slab-sizeclass slab) (- n-fixnum-tag-bits)) + (slab-chunk-size slab) + (slab-capacity slab) + (slab-usage slab) + ;; Map is collected in reverse order, so it shows in forward order + (coerce map 'string))))))) + (when (find 0 *metaspace-freelists* :start 1 :test #'/=) + (format t "Freelists:~%")) + (do ((sizeclass 1 (1+ sizeclass))) + ((= sizeclass (length *metaspace-freelists*))) + (let ((addr (aref *metaspace-freelists* sizeclass))) + (unless (zerop addr) + (format t " sizeclass ~d~%" sizeclass) + (let ((slab (int-sap addr))) + (aver (= (sap-int (slab-prev slab)) 0)) + (loop (format t " slab @ ~x: holes=~x~%" + (sap-int slab) (slab-freelist-as-list slab)) + (let ((next (slab-next slab))) + (if (sap= next (int-sap 0)) (return)) + (aver (sap= (slab-prev next) slab)) + (setq slab next))))))) + (do ((ptr (metaspace-slab-recycler)) + (list)) + ((= ptr 0) + (when list + (format t "Recycle: ~x~%" (nreverse list)))) + (push ptr list) + (setq ptr (sap-int (slab-next (int-sap ptr)))))) + +(defun slab-chunk-at (slab-base object-index) ; for hand-testing only + (declare (word slab-base)) + (let* ((slab (int-sap slab-base)) + (capacity (slab-capacity slab))) + (if (< object-index capacity) + (let ((ptr (sap+ slab + (- metaspace-slab-size + ;; Step backwards N objects + (* (slab-chunk-size slab) + (- capacity object-index)))))) + (when (chunk-used-p ptr) + (%make-lisp-obj (logior (sap-int ptr) instance-pointer-lowtag)))) + (warn "bad index")))) + +#| +(defun unallocate-lispobj (obj) + (unallocate-chunk (- (get-lisp-obj-address obj) instance-pointer-lowtag))) + +(defun unallocate-chunk-at (slab-base object-index) + (let ((obj (slab-chunk-at slab-base object-index))) + (when obj + (unallocate-lispobj obj)))) + +(defun dealloc-metaspace () + (fill *metaspace-freelists* 0) + (dolist (tract *metaspace-tracts*) + (deallocate-system-memory (tract-base tract) metaspace-tract-size)) + (setq *metaspace-tracts* nil)) +|# diff -Nru sbcl-2.1.1/src/code/mips-vm.lisp sbcl-2.1.11/src/code/mips-vm.lisp --- sbcl-2.1.1/src/code/mips-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/mips-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -6,6 +6,9 @@ "Returns a string describing the type of the local machine." "MIPS") +(defun return-machine-address (scp) + (context-register scp lip-offset)) + (define-alien-routine ("os_context_bd_cause" context-bd-cause-int) unsigned-int (context (* os-context-t) :in)) diff -Nru sbcl-2.1.1/src/code/misc-aliens.lisp sbcl-2.1.11/src/code/misc-aliens.lisp --- sbcl-2.1.1/src/code/misc-aliens.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/misc-aliens.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,11 +18,29 @@ (define-alien-variable ("static_space_free_pointer" sb-vm:*static-space-free-pointer*) system-area-pointer) +#+darwin-jit +(define-alien-variable ("static_code_space_free_pointer" sb-vm:*static-code-space-free-pointer*) + system-area-pointer) + (declaim (inline memmove)) -(define-alien-routine ("memmove" memmove) void +(define-alien-routine ("memmove" memmove) void ; BUG: technically returns void* (dest (* char)) (src (* char)) - (n unsigned-int)) + (n sb-unix::size-t)) + +(defun copy-ub8-to-system-area (src src-offset dst dst-offset length) + (with-pinned-objects (src) + (memmove (sap+ dst dst-offset) (sap+ (vector-sap src) src-offset) length)) + (values)) + +(defun copy-ub8-from-system-area (src src-offset dst dst-offset length) + (with-pinned-objects (dst) + (memmove (sap+ (vector-sap dst) dst-offset) (sap+ src src-offset) length)) + (values)) + +(defun system-area-ub8-copy (src src-offset dst dst-offset length) + (memmove (sap+ dst dst-offset) (sap+ src src-offset) length) + (values)) (define-alien-routine ("os_get_errno" get-errno) int) (setf (documentation 'get-errno 'function) diff -Nru sbcl-2.1.1/src/code/misc.lisp sbcl-2.1.11/src/code/misc.lisp --- sbcl-2.1.1/src/code/misc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/misc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -16,7 +16,5 @@ "SBCL") (defun lisp-implementation-version () - ;; Read the version file once and once only - #+sb-xc-host #.(sb-cold:read-from-file "version.lisp-expr") + #+sb-xc-host #.sb-cold:*target-sbcl-version* #-sb-xc-host #.(lisp-implementation-version)) - diff -Nru sbcl-2.1.1/src/code/module.lisp sbcl-2.1.11/src/code/module.lisp --- sbcl-2.1.1/src/code/module.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/module.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -82,8 +82,9 @@ (merge-pathnames (make-pathname :directory (list :relative "contrib") :name filesys-name) - (truename (or (sbcl-homedir-pathname) - (return-from module-provide-contrib nil))))) + ;; DO NOT CALL TRUENAME HERE. YOU SHOULD NOT NEED THAT. + (or (sbcl-homedir-pathname) + (return-from module-provide-contrib nil)))) (fasl-path (merge-pathnames (make-pathname :type *fasl-file-type*) unadorned-path)) @@ -93,9 +94,24 @@ ;; be removed by the time we get round to trying to load it. ;; Maybe factor out the logic in the LOAD guesser as to which file ;; was meant, so that we can use it here on open streams instead? - (let ((file (or (probe-file fasl-path) - (probe-file unadorned-path) - (probe-file lisp-path)))) + ;; + ;; Prefer the untruename as the argument to give to LOAD, + ;; because users need to see (in backtraces and similar) the pathnames + ;; actually handed off to the filesystem calls, like: + ;; ... #P"blaze-out/k8-fastbuild/bin/third_party/lisp/sbcl/binary-distribution/k8/sbcl/bin/../lib/sbcl/contrib/sb-md5.fasl" + ;; and not names that have been obtained through readlink like + ;; ... #P"/build/cas/081/081f9f05e4af917b63b6ccf7453e4565fc66587a093a45fb1c6dbe64e8c8ad58_0100b65b" + ;; as the latter can not be reverse-engineered to a source file + ;; except possibly by much trial and error. + ;; + ;; If the idea of using PROBE-FILE was to get the newest version + ;; on a versioned file system, I don't see how it helps to truenameize early, + ;; because as per the "possible race" cited above, there may be an even newer version + ;; when you call LOAD, or it may go away. Aside from ensuring existence, + ;; was there any benefit to using the result of PROBE-FILE? + (let ((file (cond ((probe-file fasl-path) fasl-path) + ((probe-file unadorned-path) unadorned-path) + ((probe-file lisp-path) lisp-path)))) (when file (handler-bind (((or style-warning package-at-variance) #'muffle-warning)) diff -Nru sbcl-2.1.1/src/code/ntrace.lisp sbcl-2.1.11/src/code/ntrace.lisp --- sbcl-2.1.1/src/code/ntrace.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/ntrace.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -649,8 +649,8 @@ (let ((sap (int-sap (get-lisp-obj-address code)))) ;; NB: This is not threadsafe on machines that don't promise that ;; stores to single bytes are atomic. - (setf (sap-ref-8 sap #+little-endian (- 1 sb-vm:other-pointer-lowtag) - #+big-endian (- 6 sb-vm:other-pointer-lowtag)) + (setf (sb-vm::sap-ref-8-jit sap #+little-endian (- 1 sb-vm:other-pointer-lowtag) + #+big-endian (- 6 sb-vm:other-pointer-lowtag)) bit) ;; touch the card mark (setf (code-header-ref code 1) (code-header-ref code 1))))) @@ -758,10 +758,14 @@ (setf (sap-ref-word (int-sap (get-lisp-obj-address traced-fun)) (- sb-vm:n-word-bytes sb-vm:fun-pointer-lowtag)) tracing-wrapper-entry) - #-(or x86 x86-64) + #-(or x86 x86-64 darwin-jit) (setf (sap-ref-lispobj (int-sap (get-lisp-obj-address traced-fun)) (- sb-vm:n-word-bytes sb-vm:fun-pointer-lowtag)) - tracing-wrapper)))))) + tracing-wrapper) + #+darwin-jit + (setf (sb-vm::sap-ref-word-jit (int-sap (get-lisp-obj-address traced-fun)) + (- sb-vm:n-word-bytes sb-vm:fun-pointer-lowtag)) + (get-lisp-obj-address tracing-wrapper))))))) ;; Update fdefn's raw-addr slot to point to the tracing wrapper (when (and fdefn (eq (fdefn-fun fdefn) traced-fun)) (setf (fdefn-fun fdefn) tracing-wrapper)) diff -Nru sbcl-2.1.1/src/code/numbers.lisp sbcl-2.1.11/src/code/numbers.lisp --- sbcl-2.1.1/src/code/numbers.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/numbers.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1102,7 +1102,7 @@ (values n m)) (* (truncate max (gcd n m)) min))))) -(declaim (inline fixnum-gcd)) +(declaim (maybe-inline fixnum-gcd)) (defun fixnum-gcd (u v) (declare (optimize (safety 0))) (locally @@ -1131,7 +1131,8 @@ ;;; of 0 before the dispatch so that the bignum code doesn't have to worry ;;; about "small bignum" zeros. (defun two-arg-gcd (u v) - (declare (muffle-conditions compiler-note)) + (declare (muffle-conditions compiler-note) + (inline fixnum-gcd)) (cond ((eql u 0) (abs v)) ((eql v 0) (abs u)) (t @@ -1166,7 +1167,6 @@ (values x y) (values (truncate x gcd) (truncate y gcd))) (build-ratio num den))))) -(declaim (notinline fixnum-gcd)) (defun two-arg-/ (x y) (number-dispatch ((x number) (y number)) @@ -1344,10 +1344,6 @@ (do-mfuns sb-c::*tagged-modular-class*))) `(progn ,@(sort (forms) #'string< :key #'cadr))) -;;; KLUDGE: these out-of-line definitions can't use the modular -;;; arithmetic, as that is only (currently) defined for constant -;;; shifts. See also the comment in (LOGAND OPTIMIZER) for more -;;; discussion of this hack. -- CSR, 2003-10-09 #-(or 64-bit 64-bit-registers) (defun sb-vm::ash-left-mod32 (integer amount) (etypecase integer @@ -1368,3 +1364,17 @@ (etypecase integer (fixnum (sb-c::mask-signed-field fixnum-width (ash integer amount))) (integer (sb-c::mask-signed-field fixnum-width (ash (sb-c::mask-signed-field fixnum-width integer) amount)))))) + +(sb-c::when-vop-existsp (:translate sb-vm::ash-modfx) + (defun sb-vm::ash-mod64 (integer amount) + (etypecase integer + ((unsigned-byte 64) (ldb (byte 64 0) (ash integer amount))) + (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount))) + (bignum (ldb (byte 64 0) + (ash (logand integer #xffffffffffffffff) amount))))) + + (defun sb-vm::ash-modfx (integer amount) + (let ((fixnum-width (- sb-vm:n-word-bits sb-vm:n-fixnum-tag-bits))) + (etypecase integer + (fixnum (sb-c::mask-signed-field fixnum-width (ash integer amount))) + (integer (sb-c::mask-signed-field fixnum-width (ash (sb-c::mask-signed-field fixnum-width integer) amount))))))) diff -Nru sbcl-2.1.1/src/code/octets.lisp sbcl-2.1.11/src/code/octets.lisp --- sbcl-2.1.1/src/code/octets.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/octets.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -22,6 +22,9 @@ ;;; encoding condition +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *safety-0* '(safety 0))) + (define-condition octets-encoding-error (character-encoding-error) ((string :initarg :string :reader octets-encoding-error-string) (position :initarg :position :reader octets-encoding-error-position) @@ -181,7 +184,7 @@ ;; this, you generally want a load-time ref to a global constant. ;(declaim (inline ,byte-char-name)) (defun ,byte-char-name (byte) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type (unsigned-byte 8) byte)) ,(let ((byte-to-code (loop for byte below 256 @@ -203,7 +206,7 @@ `(aref ,(sb-c::coerce-to-smallest-eltype byte-to-code) byte)))) (defun ,code-byte-name (code) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type char-code code)) (if (< code ,lowest-non-equivalent-code) code @@ -253,7 +256,7 @@ do (let ((byte (funcall get-bytes string pos))) (typecase byte ((unsigned-byte 8) - (locally (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (locally (declare (optimize (sb-c:insert-array-bounds-checks 0))) (setf (aref octets index) byte))) ((simple-array (unsigned-byte 8) (*)) ;; KLUDGE: We ran into encoding errors. Bail and do @@ -295,7 +298,7 @@ `(progn (declaim (inline ,name)) (defun ,name (string sstart send array astart aend mapper) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type simple-string string) (type ,type array) (type array-range sstart send astart aend) @@ -312,7 +315,7 @@ `(progn (declaim (inline ,name)) (defun ,name (array astart aend mapper) - (declare (optimize speed (safety 0)) + (declare (optimize speed #.*safety-0*) (type ,type array) (type array-range astart aend) (type function mapper)) @@ -402,12 +405,6 @@ (funcall (ef-string-to-octets-fun ef) string start end (if null-terminate 1 0))))) -#+sb-unicode -(defvar +unicode-replacement-character+ (string (code-char #xfffd))) -#+sb-unicode -(defun use-unicode-replacement-char (condition) - (use-value +unicode-replacement-character+ condition)) - ;;; Vector of all available EXTERNAL-FORMAT instances. Each format is named ;;; by one or more keyword symbols. The mapping from symbol to index into this ;;; vector is memoized into the symbol's :EXTERNAL-FORMAT property. diff -Nru sbcl-2.1.1/src/code/package.lisp sbcl-2.1.11/src/code/package.lisp --- sbcl-2.1.1/src/code/package.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/package.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -57,7 +57,7 @@ (sb-xc:defstruct (package (:constructor %make-package - (%name internal-symbols external-symbols)) + (internal-symbols external-symbols)) (:copier nil) (:predicate packagep)) "the standard structure for the description of a package" @@ -93,12 +93,7 @@ (%local-nicknames nil :type (or null (cons simple-vector simple-vector))) ;; Definition source location (source-location nil :type (or null sb-c:definition-source-location))) -(sb-xc:proclaim '(freeze-type package-hashtable package)) -(!set-load-form-method package (:xc) - (lambda (obj env) - (declare (ignore env)) - ;; the target code will use FIND-UNDELETED-PACKAGE-OR-LOSE - `(find-package ,(package-name obj)))) +(proclaim '(freeze-type package-hashtable package)) (defconstant +initial-package-bits+ 2) ; for genesis @@ -109,7 +104,7 @@ (defmacro package-lock (package) `(logbitp 0 (package-%bits ,package))) ;;;; IN-PACKAGE -(sb-xc:proclaim '(special *package*)) +(proclaim '(special *package*)) (sb-xc:defmacro in-package (string-designator) (let ((string (string string-designator))) `(eval-when (:compile-toplevel :load-toplevel :execute) diff -Nru sbcl-2.1.1/src/code/parse-defmacro-errors.lisp sbcl-2.1.11/src/code/parse-defmacro-errors.lisp --- sbcl-2.1.1/src/code/parse-defmacro-errors.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/parse-defmacro-errors.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -56,7 +56,7 @@ (n-actual (if (proper-list-p actual) (length actual) nil))) (format stream "~A elements in ~2I~_~:S ~ - ~I~_to satisfy lambda list ~2I~_~:S: ~I~_" + ~I~_to satisfy lambda list ~2I~_~/sb-impl:print-lambda-list/: ~I~_" (cond ((and n-actual (< n-actual min)) "too few") ((and n-actual max (> n-actual max)) "too many") (t "invalid number of")) diff -Nru sbcl-2.1.1/src/code/pathname.lisp sbcl-2.1.11/src/code/pathname.lisp --- sbcl-2.1.1/src/code/pathname.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/pathname.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -76,7 +76,7 @@ (let ((to (find-layout 'logical-pathname)) (from (find-layout 'pathname))) - (setf (layout-info to) (layout-info from) - (layout-slot-table to) (layout-slot-table from))) + (setf (wrapper-info to) (wrapper-info from) + (wrapper-slot-table to) (wrapper-slot-table from))) (declaim (inline logical-pathname-p)) (defun logical-pathname-p (x) (typep x 'logical-pathname)) diff -Nru sbcl-2.1.1/src/code/ppc-vm.lisp sbcl-2.1.11/src/code/ppc-vm.lisp --- sbcl-2.1.1/src/code/ppc-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/ppc-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -6,6 +6,10 @@ "Returns a string describing the type of the local machine." #-64-bit "PowerPC" #+64-bit "PowerPC64") + +(defun return-machine-address (scp) + (sap-int (context-lr scp))) + ;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then @@ -27,13 +31,15 @@ (* long) (context (* os-context-t)) (index int)) -#+nil (defun context-float-register (context index format) (declare (type (alien (* os-context-t)) context)) + (error "context-float-register not working yet? ~S" (list context index format)) + #+nil (coerce (deref (context-float-register-addr context index)) format)) -#+nil (defun %set-context-float-register (context index format new) (declare (type (alien (* os-context-t)) context)) + (error "%set-context-float-register not working yet? ~S" (list context index format new)) + #+nil (setf (deref (context-float-register-addr context index)) (coerce new format))) diff -Nru sbcl-2.1.1/src/code/pprint.lisp sbcl-2.1.11/src/code/pprint.lisp --- sbcl-2.1.1/src/code/pprint.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/pprint.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -756,6 +756,9 @@ (pprint-dispatch-entry-priority entry) (pprint-dispatch-entry-initial-p entry)))) +(defmethod print-object ((table pprint-dispatch-table) stream) + (print-unreadable-object (table stream :type t :identity t))) + ;; Return T iff E1 is strictly less preferable than E2. (defun entry< (e1 e2) (declare (type pprint-dispatch-entry e1 e2)) @@ -777,7 +780,7 @@ (or (and (eq (info :type :kind type-spec) :instance) (let ((layout (info :type :compiler-layout type-spec))) (and layout - (let ((info (layout-info layout))) + (let ((info (wrapper-info layout))) (and info (let ((pred (dd-predicate-name info))) (and pred (fboundp pred) @@ -804,7 +807,7 @@ (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) (declare (type (or pprint-dispatch-table null) table)) (let* ((orig (or table *initial-pprint-dispatch-table*)) - (new (make-pprint-dispatch-table (copy-list (pp-dispatch-entries orig)) + (new (make-pprint-dispatch-table (copy-seq (pp-dispatch-entries orig)) (pp-dispatch-number-matchable-p orig) (pp-dispatch-only-initial-entries orig)))) (hash-table-replace (pp-dispatch-cons-entries new) (pp-dispatch-cons-entries orig)) @@ -839,13 +842,13 @@ (and (consp object) (sb-impl::gethash/eql (car object) (pp-dispatch-cons-entries table) nil)))) (cond ((not cons-entry) - (dolist (entry (pp-dispatch-entries table) nil) + (dovector (entry (pp-dispatch-entries table) nil) (when (funcall (pprint-dispatch-entry-test-fn entry) object) (return entry)))) ((pp-dispatch-only-initial-entries table) cons-entry) (t - (dolist (entry (pp-dispatch-entries table) cons-entry) + (dovector (entry (pp-dispatch-entries table) cons-entry) (when (entry< entry cons-entry) (return cons-entry)) (when (funcall (pprint-dispatch-entry-test-fn entry) object) @@ -860,9 +863,9 @@ :operation operation))) (defun defer-type-checker (entry) - (let ((saved-nonce sb-c::*type-cache-nonce*)) + (let ((saved-nonce sb-kernel::*type-cache-nonce*)) (lambda (obj) - (let ((nonce sb-c::*type-cache-nonce*)) + (let ((nonce sb-kernel::*type-cache-nonce*)) (if (eq nonce saved-nonce) nil (let ((ctype (specifier-type (pprint-dispatch-entry-type entry)))) @@ -919,16 +922,16 @@ (remhash key hashtable)))) (setf (pp-dispatch-only-initial-entries table) nil (pp-dispatch-entries table) - (let ((list (delete type (pp-dispatch-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal))) + (let ((old (remove type (pp-dispatch-entries table) + :key #'pprint-dispatch-entry-type + :test #'equal))) (if function ;; ENTRY< is T if lower in priority, which should sort to ;; the end, but MERGE's predicate wants T for the (a,b) pair ;; if 'a' should go in front of 'b', so swap them. ;; (COMPLEMENT #'entry<) is unstable wrt insertion order. - (merge 'list list (list entry) (lambda (a b) (entry< b a))) - list))))) + (merge 'vector old (list entry) (lambda (a b) (entry< b a))) + old))))) nil) ;;;; standard pretty-printing routines @@ -1483,34 +1486,52 @@ (t (incf (car state)))))) +;;; Warm bootup is slightly less brittle if we can avoid first having to run +;;; the compiler to make some predicates for the initial PPD type specifiers. +;;; In particular I'm trying to eradicate a bunch of PARSE-UNKNOWN conditions +;;; that occur, e.g. installing (AND ARRAY (NOT (OR STRING BIT-VECTOR))) +;;; entails (compile nil '(typep sb-pretty::object )) +;;; -> (sb-c::find-free-fun typep) +;;; -> (sb-kernel:specifier-type (function (t (or cons symbol sb-kernel:classoid class) ...))) +;;; -> (sb-kernel::parse-args-types ...) +;;; -> (sb-kernel::%parse-type CLASS) +;;; where the type specifier for CLASS is as yet unknown +(defmacro initial-entry (specifier handler priority &optional predicate) + `(make-pprint-dispatch-entry + ',specifier ,priority #',handler + ,(or predicate + `(named-lambda ,(format nil "~A-P" handler) (x) + ,(sb-c::source-transform-typep 'x specifier))))) + (defun !pprint-cold-init () (/show0 "entering !PPRINT-COLD-INIT") ;; Kludge: We set *STANDARD-PP-D-TABLE* to a new table even though ;; it's going to be set to a copy of *INITIAL-PP-D-T* below because ;; it's used in WITH-STANDARD-IO-SYNTAX, and condition reportery ;; possibly performed in the following extent may use W-S-IO-SYNTAX. - (setf *standard-pprint-dispatch-table* (make-pprint-dispatch-table nil nil nil)) + (setf *standard-pprint-dispatch-table* (make-pprint-dispatch-table #() nil nil)) (setf *initial-pprint-dispatch-table* nil) - (let ((*print-pprint-dispatch* (make-pprint-dispatch-table nil nil nil))) - (/show0 "doing SET-PPRINT-DISPATCH for regular types") - ;; * PLEASE NOTE : If you change these definitions, then you may need to adjust - ;; the computation of POSSIBLY-MATCHABLE in PPRINT-DISPATCH. - ;; - ;; Assign a lower priority than for the cons entries below, making - ;; fewer type tests when dispatching. - (set-pprint-dispatch '(and array (not (or string bit-vector))) 'pprint-array -1) - ;; MACRO-FUNCTION must have effectively higher priority than FBOUNDP. - ;; The implementation happens to check identical priorities in the order added, - ;; but that's unspecified behavior. Both must be _strictly_ lower than the - ;; default cons entries though. - (set-pprint-dispatch '(cons (and symbol (satisfies macro-function))) - 'pprint-macro-call -1) - (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) - 'pprint-fun-call -1) - (set-pprint-dispatch '(cons symbol) - 'pprint-data-list -2) - (set-pprint-dispatch 'cons 'pprint-fill -2) - (set-pprint-dispatch 'sb-impl::comma 'pprint-unquoting-comma -3) + (let* ((initial-entries + (vector + ;; * PLEASE NOTE : If you change these definitions, then you may need to adjust + ;; the computation of POSSIBLY-MATCHABLE in PPRINT-DISPATCH. + ;; + ;; Assign a lower priority than for the cons entries below, making + ;; fewer type tests when dispatching. + (initial-entry (and array (not (or string bit-vector))) + pprint-array -1) + ;; MACRO-FUNCTION must have effectively higher priority than FBOUNDP. + ;; The implementation happens to check identical priorities in the order added, + ;; but that's unspecified behavior. Both must be _strictly_ lower than the + ;; default cons entries though. + (initial-entry (cons (and symbol (satisfies macro-function))) + pprint-macro-call -1) + (initial-entry (cons (and symbol (satisfies fboundp))) pprint-fun-call -1) + (initial-entry (cons symbol) pprint-data-list -2) + (initial-entry cons pprint-fill -2 #'consp) + (initial-entry sb-impl::comma pprint-unquoting-comma -3 #'comma-p))) + (*print-pprint-dispatch* + (make-pprint-dispatch-table initial-entries nil nil))) ;; cons cells with interesting things for the car (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR") (dolist (magic-form '((lambda pprint-lambda) diff -Nru sbcl-2.1.1/src/code/pred.lisp sbcl-2.1.11/src/code/pred.lisp --- sbcl-2.1.1/src/code/pred.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/pred.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -17,6 +17,11 @@ (defun streamp (stream) (typep stream 'stream)) +;;; These would only be called from %%TYPEP given a built-in-classoid. +;;; Ordinarily TYPEP on either one would be transformed. +(defun sb-kernel::file-stream-p (x) (typep x 'file-stream)) +(defun sb-kernel::string-stream-p (x) (typep x 'string-stream)) + ;;; various (VECTOR FOO) type predicates, not implemented as simple ;;; widetag tests (macrolet @@ -93,10 +98,15 @@ (def-type-predicate-wrapper fixnump) (def-type-predicate-wrapper floatp) (def-type-predicate-wrapper functionp) + ;; SIMPLE-FUN-P is needed for constant folding in early warm load, + ;; and its absence would be obscured by the fact that + ;; CONSTANT-FUNCTION-CALL-P allows the call to fail. + (def-type-predicate-wrapper closurep) + (def-type-predicate-wrapper simple-fun-p) (def-type-predicate-wrapper integerp) (def-type-predicate-wrapper listp) (def-type-predicate-wrapper long-float-p) - #-(or x86 x86-64) (def-type-predicate-wrapper lra-p) + #-(or x86 x86-64 arm64) (def-type-predicate-wrapper lra-p) (def-type-predicate-wrapper null) (def-type-predicate-wrapper numberp) (def-type-predicate-wrapper rationalp) @@ -145,59 +155,6 @@ (and (fixnump x) (<= 0 x limit))) -;;; a vector that maps widetags to layouts, used for quickly finding -;;; the layouts of built-in classes -(define-load-time-global **primitive-object-layouts** nil) -(declaim (type simple-vector **primitive-object-layouts**)) -(defun !pred-cold-init () - ;; This vector is allocated in immobile space when possible. There isn't - ;; a way to do that from lisp, so it's special-cased in genesis. - #-immobile-space (setq **primitive-object-layouts** (make-array 256)) - (map-into **primitive-object-layouts** - (lambda (name) (classoid-layout (find-classoid name))) - #.(let ((table (make-array 256 :initial-element 'sb-kernel::random-class))) - (dolist (x sb-kernel::+!built-in-classes+) - (destructuring-bind (name &key codes &allow-other-keys) x - (dolist (code codes) - (setf (svref table code) name)))) - (loop for i from sb-vm:list-pointer-lowtag by (* 2 sb-vm:n-word-bytes) - below 256 - do (setf (aref table i) 'cons)) - (loop for i from sb-vm:even-fixnum-lowtag by (ash 1 sb-vm:n-fixnum-tag-bits) - below 256 - do (setf (aref table i) 'fixnum)) - table))) - -;;; Return the layout for an object. This is the basic operation for -;;; finding out the "type" of an object, and is used for generic -;;; function dispatch. The standard doesn't seem to say as much as it -;;; should about what this returns for built-in objects. For example, -;;; it seems that we must return NULL rather than LIST when X is NIL -;;; so that GF's can specialize on NULL. -;;; x86-64 has a vop that implements this without even needing to place -;;; the vector of layouts in the constant pool of the containing code. -#-(and compact-instance-header x86-64) -(progn -(declaim (inline layout-of)) -(defun layout-of (x) - (declare (optimize (speed 3) (safety 0))) - (cond ((%instancep x) (%instance-layout x)) - ((funcallable-instance-p x) (%fun-layout x)) - ;; Compiler can dump literal layouts, which handily sidesteps - ;; the question of when cold-init runs L-T-V forms. - ((null x) #.(find-layout 'null)) - (t - ;; Note that WIDETAG-OF is slightly suboptimal here and could be - ;; improved - we've already ruled out some of the lowtags. - (svref (load-time-value **primitive-object-layouts** t) - (widetag-of x)))))) - -(declaim (inline classoid-of)) -#-sb-xc-host -(defun classoid-of (object) - "Return the class of the supplied object, which may be any Lisp object, not - just a CLOS STANDARD-OBJECT." - (layout-classoid (layout-of object))) ;;; Return the specifier for the type of object. This is not simply ;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different @@ -234,7 +191,7 @@ ((eq (sb-xc:symbol-package object) *keyword-package*) 'keyword) (t 'symbol))) (array - (let ((etype (specifier-type (array-element-type object)))) + (let ((etype (sb-vm::array-element-ctype object))) ;; Obviously :COMPLEXP is known to be T or NIL, but it's not allowed to ;; return (NOT SIMPLE-ARRAY), so use :MAYBE in lieu of T. (type-specifier @@ -246,24 +203,32 @@ (type-specifier (ctype-of object))) (simple-fun 'compiled-function) (t - (let ((layout (layout-of object))) - (if (eq (get-lisp-obj-address layout) 0) - ;; An empty instance, e.g. created by with-output-to-string - 'instance - (let* ((classoid (layout-classoid layout)) - (name (classoid-name classoid))) - (if (%instancep object) - (case name - (sb-alien-internals:alien-value - `(alien - ,(sb-alien-internals:unparse-alien-type - (sb-alien-internals:alien-value-type object)))) - (t - (let ((pname (classoid-proper-name classoid))) - (if (classoid-p pname) - (classoid-pcl-class pname) - pname)))) - name))))))) + #+metaspace ; WRAPPER-OF can't be called on layoutless objects. + (unless (logtest (get-lisp-obj-address (%instanceoid-layout object)) + sb-vm:widetag-mask) + ;; [fun-]instances momentarily have no layout in any code interrupted + ;; just after allocating and before assigning slots. + ;; OUTPUT-UGLY-OBJECT has a similar precaution as this. + (return-from type-of (if (functionp object) 'funcallable-instance 'instance))) + (let ((wrapper (wrapper-of object))) + #-metaspace ; already checked for a good layout if metaspace + (when (= (get-lisp-obj-address wrapper) 0) + (return-from type-of + (if (functionp object) 'funcallable-instance 'instance))) + (let* ((classoid (wrapper-classoid wrapper)) + (name (classoid-name classoid))) + ;; FIXME: should the first test be (not (or (%instancep) (%funcallable-instance-p)))? + ;; God forbid anyone makes anonymous classes of generic functions. + (cond ((not (%instancep object)) + name) + ((eq name 'sb-alien-internals:alien-value) + `(alien ,(sb-alien-internals:unparse-alien-type + (sb-alien-internals:alien-value-type object)))) + (t + (let ((pname (classoid-proper-name classoid))) + (if (classoid-p pname) + (classoid-pcl-class pname) + pname))))))))) ;;;; equality predicates @@ -283,8 +248,8 @@ ;; Anyway it suffices to disable type checking and pretend its the always ;; the first arg that's an integer, but that won't work on the host because ;; it might enforce the type since we can't portably unenforce after declaring. - #-sb-xc-host (declare (optimize (sb-c::type-check 0))) - (eql #+sb-xc-host obj1 #-sb-xc-host (the integer obj1) obj2)) + (declare (optimize (sb-c::type-check 0))) + (eql (the integer obj1) obj2)) (declaim (inline %eql)) (defun %eql (obj1 obj2) @@ -432,49 +397,96 @@ ((functionp test) (funcall test i x y)) (t))))) -;;; Doesn't work on simple vectors -(defun array-equalp (x y) - (declare (array x y)) - (let ((rank (array-rank x))) - (and - (= rank (array-rank y)) - (dotimes (axis rank t) - (unless (= (%array-dimension x axis) - (%array-dimension y axis)) - (return nil))) - (with-array-data ((x x) (start-x) (end-x) :force-inline t - :array-header-p t) - (with-array-data ((y y) (start-y) (end-y) :force-inline t - :array-header-p t) - (declare (ignore end-y)) - (let* ((reffers %%data-vector-reffers%%) - (getter-x (truly-the function (svref reffers (%other-pointer-widetag x)))) - (getter-y (truly-the function (svref reffers (%other-pointer-widetag y))))) - (loop for x-i fixnum from start-x below end-x - for y-i fixnum from start-y - for x-el = (funcall getter-x x x-i) - for y-el = (funcall getter-y y y-i) - always (or (eq x-el y-el) - (equalp x-el y-el))))))))) - -(defun vector-equalp (x y) - (declare (vector x y)) - (let ((length (length x))) - (and (= length (length y)) - (with-array-data ((x x) (start-x) (end-x) :force-inline t - :check-fill-pointer t) - (with-array-data ((y y) (start-y) (end-y) :force-inline t - :check-fill-pointer t) - (declare (ignore end-y)) - (let* ((reffers %%data-vector-reffers%%) - (getter-x (truly-the function (svref reffers (%other-pointer-widetag x)))) - (getter-y (truly-the function (svref reffers (%other-pointer-widetag y))))) - (loop for x-i fixnum from start-x below end-x - for y-i fixnum from start-y - for x-el = (funcall getter-x x x-i) - for y-el = (funcall getter-y y y-i) - always (or (eq x-el y-el) - (equalp x-el y-el))))))))) +(macrolet ((numericp (v) + (let ((widetags + (map 'list #'sb-vm:saetp-typecode + (remove-if (lambda (x) + (not (typep (sb-vm:saetp-ctype x) 'numeric-type))) + sb-vm:*specialized-array-element-type-properties*)))) + `(%other-pointer-subtype-p ,v ',widetags))) + (compare-loop (typespec) + `(let ((x (truly-the (simple-array ,typespec 1) x)) + (y (truly-the (simple-array ,typespec 1) y))) + (loop for x-i fixnum from start-x below end-x + for y-i fixnum from start-y + always (= (aref x x-i) (aref y y-i)))))) +(defun array-equalp (a b) + (flet + ((data-vector-compare (x y start-x end-x start-y) + (declare (index start-x end-x start-y) + (optimize (sb-c:insert-array-bounds-checks 0))) + (let ((xtag (%other-pointer-widetag (truly-the (simple-array * 1) x))) + (ytag (%other-pointer-widetag (truly-the (simple-array * 1) y)))) + (case (if (= xtag ytag) xtag 0) + (#.sb-vm:simple-vector-widetag + (let ((x (truly-the simple-vector x)) + (y (truly-the simple-vector y))) + (loop for x-i fixnum from start-x below end-x + for y-i fixnum from start-y + always (let ((a (svref x x-i)) (b (svref y y-i))) + (or (eq a b) (equalp a b)))))) + ;; Special-case the important array types that would cause consing in aref. + ;; Though (UNSIGNED-BYTE 62) and (UNSIGNED-BYTE 63) arrays exist, + ;; I highly doubt that they occur anywhere except in contrived code + ;; that does nothing but test that those types exist. i.e. They are + ;; beyond worthless, and are frankly wasteful of space in array dispatch + ;; scenarios, or to put it mildy: I disagree with their existence per se. + #+64-bit (#.sb-vm:simple-array-unsigned-byte-64-widetag + (compare-loop (unsigned-byte 64))) + #+64-bit (#.sb-vm:simple-array-signed-byte-64-widetag + (compare-loop (signed-byte 64))) + #-64-bit (#.sb-vm:simple-array-unsigned-byte-32-widetag + (compare-loop (unsigned-byte 32))) + #-64-bit (#.sb-vm:simple-array-signed-byte-32-widetag + (compare-loop (signed-byte 32))) + ;; SINGLE-FLOAT wouldn't cons on 64-bit, but it should be treated + ;; no less efficiently than DOUBLE-FLOAT. + (#.sb-vm:simple-array-single-float-widetag + (compare-loop single-float)) + (#.sb-vm:simple-array-double-float-widetag + (compare-loop double-float)) + (#.sb-vm:simple-array-complex-single-float-widetag + (compare-loop (complex single-float))) + (#.sb-vm:simple-array-complex-double-float-widetag + (compare-loop (complex double-float))) + (t + (let* ((reffers %%data-vector-reffers%%) + (getter-x (truly-the function (svref reffers xtag))) + (getter-y (truly-the function (svref reffers ytag)))) + ;; The arrays won't both be strings, because EQUALP has a case for that. + ;; If they're both numeric, use = as the test. + (if (and (numericp x) (numericp y)) + (loop for x-i fixnum from start-x below end-x + for y-i fixnum from start-y + always (= (funcall getter-x x x-i) (funcall getter-y y y-i))) + ;; Everything else + (loop for x-i fixnum from start-x below end-x + for y-i fixnum from start-y + for x-el = (funcall getter-x x x-i) + for y-el = (funcall getter-y y y-i) + always (or (eq x-el y-el) + (equalp x-el y-el)))))))))) + (if (vectorp (truly-the array a)) + (and (vectorp (truly-the array b)) + (= (length a) (length b)) + (with-array-data ((x a) (start-x) (end-x) + :force-inline t :check-fill-pointer t) + (with-array-data ((y b) (start-y) (end-y) + :force-inline t :check-fill-pointer t) + (declare (ignore end-y)) + (data-vector-compare x y start-x end-x start-y)))) + (let ((rank (array-rank (truly-the array a)))) + (and (= rank (array-rank (truly-the array b))) + (dotimes (axis rank t) + (unless (= (%array-dimension a axis) + (%array-dimension b axis)) + (return nil))) + (with-array-data ((x a) (start-x) (end-x) + :force-inline t :array-header-p t) + (with-array-data ((y b) (start-y) (end-y) + :force-inline t :array-header-p t) + (declare (ignore end-y)) + (data-vector-compare x y start-x end-x start-y))))))))) (defun equalp (x y) "Just like EQUAL, but more liberal in several respects. @@ -496,21 +508,14 @@ (and (logtest (logior +structure-layout-flag+ +pathname-layout-flag+) (layout-flags layout)) (eq (%instance-layout y) layout) - (funcall (layout-equalp-impl layout) x y))))) - ((and (simple-vector-p x) (simple-vector-p y)) - (let ((len (length x))) - (and (= len (length y)) - (loop for i below len ; somewhat faster than the generic loop - always (let ((a (svref x i)) (b (svref y i))) - (or (eq a b) (equalp a b))))))) - ((and (bit-vector-p x) (bit-vector-p y)) - (bit-vector-= x y)) - ((vectorp x) - (and (vectorp y) - (vector-equalp x y))) + (funcall (wrapper-equalp-impl (layout-friend layout)) + x y))))) ((arrayp x) (and (arrayp y) - (array-equalp x y))) + ;; string-equal is nearly 2x the speed of array-equalp for comparing strings + (cond ((and (stringp x) (stringp y)) (string-equal x y)) + ((and (bit-vector-p x) (bit-vector-p y)) (bit-vector-= x y)) + (t (array-equalp x y))))) (t nil))) (let ((test-cases `(($0.0 $-0.0 t) diff -Nru sbcl-2.1.1/src/code/primordial-extensions.lisp sbcl-2.1.11/src/code/primordial-extensions.lisp --- sbcl-2.1.1/src/code/primordial-extensions.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/primordial-extensions.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -321,7 +321,7 @@ ,@(when doc (list doc))))) ;;; Special variant at cross-compile-time. Face it: the "croak-if-not-EQx" test -;;; is irrelevant - there can be no pre-existing value to test against. +;;; is irrelevant - there can be no pre-existing value to test against at target load time. ;;; The extra requirement is that the EXPR must satisfy CONSTANTP so that this ;;; macroexpander can EVAL it, and then the constant value can be dumped as a literal. ;;; This in turn allows a LOAD-TIME-VALUE form referencing the constant to work @@ -332,9 +332,6 @@ (sb-xc:defmacro defconstant-eqx (symbol expr eqx &optional doc) (unless (constantp expr) (error "DEFCONSTANT-EQX requires a literal constant")) - `(progn - (eval-when (:compile-toplevel) - (defconstant ,symbol (%defconstant-eqx-value ',symbol ,expr ,eqx))) - (eval-when (:load-toplevel) - (sb-c::%defconstant ',symbol ',(eval expr) - (sb-c:source-location) ,@(when doc (list doc))))))) + `(eval-when (:compile-toplevel :load-toplevel) + (%defconstant ',symbol ',(%defconstant-eqx-value symbol (eval expr) (eval eqx)) + (sb-c:source-location) ,@(when doc (list doc)))))) diff -Nru sbcl-2.1.1/src/code/primordial-type.lisp sbcl-2.1.11/src/code/primordial-type.lisp --- sbcl-2.1.1/src/code/primordial-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/primordial-type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,6 +11,10 @@ (!begin-collecting-cold-init-forms) +;; %DEFCONSTANT needs this to be bound. +(!cold-init-forms + (setq sb-c::*compile-time-eval* nil)) + (define-type-class named :enumerable nil :might-contain-other-types nil) (macrolet ((frob (type global-sym) @@ -18,16 +22,16 @@ ;; Toggle some bits so that the hash is not equal to the hash ;; for a classoid of this name (relevant for named type T only) (perturbed-bit-string - (let ((string (format nil "~32,'0b" name-hash))) - (concatenate 'string - (subseq string 0 22) (reverse (subseq string 22))))) + (let ((string (format nil "~32,'0b" name-hash))) + (concatenate 'string + (subseq string 0 22) (reverse (subseq string 22))))) (bits `(pack-interned-ctype-bits 'named ,(parse-integer perturbed-bit-string :radix 2) ,(case type - ((*) 31) - ((nil t) (sb-vm::saetp-index-or-lose type)) - (t nil))))) + ((*) 31) + ((nil t) (sb-vm::saetp-index-or-lose type)) + (t nil))))) (declare (ignorable bits)) ; not used in XC `(progn #+sb-xc-host @@ -35,55 +39,60 @@ ;; Make it known as a constant in the cross-compiler. (setf (info :variable :kind ',global-sym) :constant)) (!cold-init-forms - #+sb-xc (sb-c::%defconstant ',global-sym ,global-sym - (sb-c:source-location)) + #+sb-xc (sb-impl::%defconstant ',global-sym ,global-sym + (sb-c:source-location)) (setf (info :type :builtin ',type) ,global-sym (info :type :kind ',type) :primitive)))))) - ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a - ;; special symbol which can be stuck in some places where an - ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1). - ;; In SBCL it also used to denote universal VALUES type. - (frob * *wild-type*) - (frob nil *empty-type*) - (frob t *universal-type*) - ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that - ;; view of them was incompatible with requirements on the MOP - ;; metaobject class hierarchy: the INSTANCE and - ;; FUNCALLABLE-INSTANCE types are disjoint (instances have - ;; instance-pointer-lowtag; funcallable-instances have - ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is - ;; required to be a subclass of STANDARD-OBJECT. -- CSR, - ;; 2005-09-09 - (frob instance *instance-type*) - (frob funcallable-instance *funcallable-instance-type*) - ;; new in sbcl-1.0.3.3: necessary to act as a join point for the - ;; extended sequence hierarchy. (Might be removed later if we use - ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.) - (frob extended-sequence *extended-sequence-type*)) + ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a + ;; special symbol which can be stuck in some places where an + ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1). + ;; In SBCL it also used to denote universal VALUES type. + (frob * *wild-type*) + (frob nil *empty-type*) + (frob t *universal-type*) + ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that + ;; view of them was incompatible with requirements on the MOP + ;; metaobject class hierarchy: the INSTANCE and + ;; FUNCALLABLE-INSTANCE types are disjoint (instances have + ;; instance-pointer-lowtag; funcallable-instances have + ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is + ;; required to be a subclass of STANDARD-OBJECT. -- CSR, + ;; 2005-09-09 + (frob instance *instance-type*) + (frob funcallable-instance *funcallable-instance-type*) + ;; new in sbcl-1.0.3.3: necessary to act as a join point for the + ;; extended sequence hierarchy. (Might be removed later if we use + ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.) + (frob extended-sequence *extended-sequence-type*)) -(!defun-from-collected-cold-init-forms !primordial-type-cold-init) +#-sb-xc-host +(progn +;;; a vector that maps widetags to layouts, used for quickly finding +;;; the layouts of built-in classes +(define-load-time-global **primitive-object-layouts** nil) +(declaim (type simple-vector **primitive-object-layouts**))) + +#-sb-xc-host +(!cold-init-forms -;;; A HAIRY-TYPE represents anything too weird to be described -;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types, -;;; and unreasonably complicated types involving AND. We just remember -;;; the original type spec. -;;; A possible improvement would be for HAIRY-TYPE to have a subtype -;;; named SATISFIES-TYPE for the hairy types which are specifically -;;; of the form (SATISFIES pred) so that we don't have to examine -;;; the sexpr repeatedly to decide whether it takes that form. -;;; And as a further improvement, we might want a table that maps -;;; predicates to their exactly recognized type when possible. -;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES* -;;; as a starting point. But something like PLUSP isn't in there. -;;; On the other hand, either of these points may not be sources of -;;; inefficiency, and the latter if implemented might have undesirable -;;; user-visible ramifications, though it seems unlikely. -(defstruct (hairy-type (:include ctype) - (:constructor %make-hairy-type - (specifier &aux (%bits (pack-ctype-bits hairy)))) - (:constructor !make-interned-hairy-type - (specifier &aux (%bits (pack-interned-ctype-bits 'hairy)))) - (:copier nil)) - ;; the Common Lisp type-specifier of the type we represent. - ;; For other than an unknown type, this must be a (SATISFIES f) expression. - (specifier nil :type t :read-only t)) +;; This vector is allocated in immobile space when possible. There isn't +;; a way to do that from lisp, so it's special-cased in genesis. +#-immobile-space (setq **primitive-object-layouts** (make-array 256)) +;; If #+metaspace, we can't generally store layouts in heap objects except in +;; the instance header, but this vector can because it too will go in metaspace. +(map-into **primitive-object-layouts** + (lambda (name) (wrapper-friend (classoid-wrapper (find-classoid name)))) + #.(let ((table (make-array 256 :initial-element 'sb-kernel::random-class))) + (dolist (x sb-kernel::*builtin-classoids*) + (destructuring-bind (name &key codes &allow-other-keys) x + (dolist (code codes) + (setf (svref table code) name)))) + (loop for i from sb-vm:list-pointer-lowtag by (* 2 sb-vm:n-word-bytes) + below 256 + do (setf (aref table i) 'cons)) + (loop for i from sb-vm:even-fixnum-lowtag by (ash 1 sb-vm:n-fixnum-tag-bits) + below 256 + do (setf (aref table i) 'fixnum)) + table))) + +(!defun-from-collected-cold-init-forms !primordial-type-cold-init) diff -Nru sbcl-2.1.1/src/code/print.lisp sbcl-2.1.11/src/code/print.lisp --- sbcl-2.1.1/src/code/print.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/print.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,50 +13,49 @@ ;;;; exported printer control variables -;; NB: all of the following are initialized during genesis -(defparameter *print-readably* nil +(defvar *print-readably* nil "If true, all objects will be printed readably. If readable printing is impossible, an error will be signalled. This overrides the value of *PRINT-ESCAPE*.") -(defparameter *print-escape* t +(defvar *print-escape* t "Should we print in a reasonably machine-readable way? (possibly overridden by *PRINT-READABLY*)") -(defparameter *print-pretty* nil ; (set later when pretty-printer is initialized) +(defvar *print-pretty* nil ; (set later when pretty-printer is initialized) "Should pretty printing be used?") -(defparameter *print-base* 10. +(defvar *print-base* 10. "The output base for RATIONALs (including integers).") -(defparameter *print-radix* nil +(defvar *print-radix* nil "Should base be verified when printing RATIONALs?") -(defparameter *print-level* nil +(defvar *print-level* nil "How many levels should be printed before abbreviating with \"#\"?") -(defparameter *print-length* nil +(defvar *print-length* nil "How many elements at any level should be printed before abbreviating with \"...\"?") -(defparameter *print-vector-length* nil +(defvar *print-vector-length* nil "Like *PRINT-LENGTH* but works on strings and bit-vectors. Does not affect the cases that are already controlled by *PRINT-LENGTH*") -(defparameter *print-circle* nil +(defvar *print-circle* nil "Should we use #n= and #n# notation to preserve uniqueness in general (and circularity in particular) when printing?") -(defparameter *print-case* :upcase +(defvar *print-case* :upcase "What case should the printer should use default?") -(defparameter *print-array* t +(defvar *print-array* t "Should the contents of arrays be printed?") -(defparameter *print-gensym* t +(defvar *print-gensym* t "Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?") -(defparameter *print-lines* nil +(defvar *print-lines* nil "The maximum number of lines to print per object.") -(defparameter *print-right-margin* nil +(defvar *print-right-margin* nil "The position of the right margin in ems (for pretty-printing).") -(defparameter *print-miser-width* nil +(defvar *print-miser-width* nil "If the remaining space between the current column and the right margin is less than this, then print using ``miser-style'' output. Miser style conditional newlines are turned on, and all indentations are turned off. If NIL, never use miser mode.") (defvar *print-pprint-dispatch* - (sb-pretty::make-pprint-dispatch-table nil nil nil) ; for type-correctness + (sb-pretty::make-pprint-dispatch-table #() nil nil) "The pprint-dispatch-table that controls how to pretty-print objects.") -(defparameter *suppress-print-errors* nil +(defvar *suppress-print-errors* nil "Suppress printer errors when the condition is of the type designated by this variable: an unreadable object representing the error is printed instead.") @@ -378,17 +377,24 @@ (return-from output-ugly-object (print-unreadable-object (object stream :identity t) (prin1 'instance stream)))) - (let ((classoid (layout-classoid layout))) + (let* ((wrapper (layout-friend layout)) + (classoid (wrapper-classoid wrapper))) ;; Additionally, don't crash if the object is an obsolete thing with ;; no update protocol. (when (or (sb-kernel::undefined-classoid-p classoid) - (and (layout-invalid layout) + (and (wrapper-invalid wrapper) (logtest (layout-flags layout) (logior +structure-layout-flag+ +condition-layout-flag+)))) (return-from output-ugly-object (print-unreadable-object (object stream :identity t) (format stream "UNPRINTABLE instance of ~W" classoid))))))) + (when (funcallable-instance-p object) + (let ((layout (%fun-layout object))) + (unless (logtest (get-lisp-obj-address layout) sb-vm:widetag-mask) + (return-from output-ugly-object + (print-unreadable-object (object stream :identity t) + (prin1 'funcallable-instance stream)))))) (print-object object stream)) ;;;; symbols @@ -497,7 +503,7 @@ :initial-element 36))) (dotimes (i 36 a) (let ((char (digit-char i 36))) - (setf (aref a (sb-xc:char-code char)) i)))) + (setf (aref a (char-code char)) i)))) #'equalp) (defconstant-eqx +character-attributes+ @@ -506,7 +512,7 @@ :element-type '(unsigned-byte 16) :initial-element 0))) (flet ((set-bit (char bit) - (let ((code (sb-xc:char-code char))) + (let ((code (char-code char))) (setf (aref a code) (logior bit (aref a code)))))) (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\} @@ -516,12 +522,12 @@ (dotimes (i 10) (set-bit (digit-char i) number-attribute)) - (do ((code (sb-xc:char-code #\A) (1+ code)) - (end (sb-xc:char-code #\Z))) + (do ((code (char-code #\A) (1+ code)) + (end (char-code #\Z))) ((> code end)) (declare (fixnum code end)) - (set-bit (sb-xc:code-char code) uppercase-attribute) - (set-bit (char-downcase (sb-xc:code-char code)) lowercase-attribute)) + (set-bit (code-char code) uppercase-attribute) + (set-bit (char-downcase (code-char code)) lowercase-attribute)) (set-bit #\- sign-attribute) (set-bit #\+ sign-attribute) @@ -1117,7 +1123,7 @@ ;; "The function SB-KERNEL:SIMPLE-CHARACTER-STRING-P is undefined." ;; but a symbol-macrolet is ok. This is a FIXME except I don't care. (symbol-macrolet ((chars "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")) - (declare (optimize (sb-c::insert-array-bounds-checks 0) speed)) + (declare (optimize (sb-c:insert-array-bounds-checks 0) speed)) (macrolet ((iterative-algorithm () `(loop (multiple-value-bind (q r) (truncate (truly-the word integer) base) @@ -1358,8 +1364,14 @@ (double-float double-float-min-e) #+long-float (long-float long-float-min-e)))) - (multiple-value-bind (f e) - (integer-decode-float float) + (multiple-value-bind (f e) (integer-decode-float float) + ;; An extra step became necessary here for subnormals because the + ;; algorithm assumes that the fraction is left-aligned in a field + ;; that is FLOAT-DIGITS wide. + (when (< (float-precision float) float-digits) + (let ((shift (- float-digits (integer-length f)))) + (setq f (ash f shift) + e (- e shift)))) (let ( ;; FIXME: these even tests assume normal IEEE rounding ;; mode. I wonder if we should cater for non-normal? (high-ok (evenp f)) @@ -1699,7 +1711,7 @@ (write-string ", " stream) (output-object (sb-c::debug-info-name dinfo) stream))))))))) -#-(or x86 x86-64) +#-(or x86 x86-64 arm64) (defmethod print-object ((lra lra) stream) (print-unreadable-object (lra stream :identity t) (write-string "return PC object" stream))) @@ -1824,6 +1836,9 @@ ;; as opposed to any other unbound marker. (print-unreadable-object (object stream) (write-string "unbound" stream)) (return-from print-object)) + (when (eql (get-lisp-obj-address object) sb-vm:no-tls-value-marker-widetag) + (print-unreadable-object (object stream) (write-string "novalue" stream)) + (return-from print-object)) (print-unreadable-object (object stream :identity t) (let ((lowtag (lowtag-of object))) (case lowtag diff -Nru sbcl-2.1.1/src/code/reader.lisp sbcl-2.1.11/src/code/reader.lisp --- sbcl-2.1.1/src/code/reader.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/reader.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -16,32 +16,13 @@ ;;; ANSI: "the floating-point format that is to be used when reading a ;;; floating-point number that has no exponent marker or that has e or ;;; E for an exponent marker" -(defparameter *read-default-float-format* 'single-float) +(defvar *read-default-float-format* 'single-float) (defvar *readtable*) -(defun gethash-return-default (key self default) - (declare (optimize (safety 0)) - (ignore key self)) - default) (defun !readtable-cold-init () - (macrolet ((nwords () - (dd-length (find-defstruct-description 'hash-table))) - (initforms () - `(setf,@(mapcan (lambda (dsd) - (list `(%instance-ref table ,(dsd-index dsd)) - (case (dsd-name dsd) - (gethash-impl '#'gethash-return-default) - (pairs (make-array kv-pairs-overhead-slots - :initial-element 0)) - (lock nil) - (t (dsd-default dsd))))) - (dd-slots - (find-defstruct-description 'hash-table)))))) - (let ((table (%make-instance (nwords)))) - (setf (%instance-layout table) #.(find-layout 'hash-table)) - (initforms) - (setq *empty-extended-char-table* table)))) + (setq *empty-extended-char-table* (make-hash-table :rehash-size 1 :test #'eq) + *readtable* (make-readtable))) (setf (documentation '*readtable* 'variable) "Variable bound to current readtable.") @@ -60,15 +41,15 @@ ;;;; reader errors (defun reader-eof-error (stream context) - (declare (optimize allow-non-returning-tail-call)) + ;; Don't worry if STREAM isn't a valid stream; it's not a reason to fail now. + (declare (explicit-check) (optimize allow-non-returning-tail-call)) (error 'reader-eof-error :stream stream :context context)) -;;; If The Gods didn't intend for us to use multiple namespaces, why -;;; did They specify them? (defun simple-reader-error (stream control &rest args) - (declare (optimize allow-non-returning-tail-call)) + ;; Don't worry if STREAM isn't a valid stream; it's not a reason to fail now. + (declare (explicit-check) (optimize allow-non-returning-tail-call)) (error 'simple-reader-error :stream stream :format-control control @@ -111,8 +92,6 @@ (extended-char-table readtable) table)) (setf (gethash char table) (cons attributes function))) ((neq table *empty-extended-char-table*) - ;; can't REMHASH from *empty-extended-char-table* - ;; since it's not a real hash-table. (remhash char table))))) nil) @@ -210,16 +189,15 @@ ;;; There are a number of "secondary" attributes which are constant ;;; properties of characters (as long as they are constituents). -;;; FIXME: this initform is considered too hairy to assign (a constant array, really?) -;;; if changed to DEFCONSTANT-EQX, which makes this file unslammable as-is. Oh well. (defconstant-eqx +constituent-trait-table+ #.(let ((a (sb-xc:make-array base-char-code-limit :retain-specialization-for-after-xc-core t :element-type '(unsigned-byte 8)))) (fill a +char-attr-constituent+) - (flet ((!set-constituent-trait (char trait) - (aver (typep char 'base-char)) - (setf (elt a (char-code char)) trait))) + (labels ((!set-code-constituent-trait (code trait) + (setf (elt a code) trait)) + (!set-constituent-trait (char trait) + (!set-code-constituent-trait (char-code char) trait))) (!set-constituent-trait #\: +char-attr-package-delimiter+) (!set-constituent-trait #\. +char-attr-constituent-dot+) (!set-constituent-trait #\+ +char-attr-constituent-sign+) @@ -227,7 +205,7 @@ (!set-constituent-trait #\/ +char-attr-constituent-slash+) (do ((i (char-code #\0) (1+ i))) ((> i (char-code #\9))) - (!set-constituent-trait (code-char i) +char-attr-constituent-digit+)) + (!set-code-constituent-trait i +char-attr-constituent-digit+)) (!set-constituent-trait #\E +char-attr-constituent-expt+) (!set-constituent-trait #\F +char-attr-constituent-expt+) (!set-constituent-trait #\D +char-attr-constituent-expt+) @@ -244,7 +222,7 @@ (!set-constituent-trait #\Newline +char-attr-invalid+) (dolist (c (list backspace-char-code tab-char-code form-feed-char-code return-char-code rubout-char-code)) - (!set-constituent-trait (code-char c) +char-attr-invalid+))) + (!set-code-constituent-trait c +char-attr-invalid+))) a) #'equalp) @@ -515,8 +493,7 @@ ;;;; temporary initialization hack ;; Install the (easy) standard macro-chars into *READTABLE*. -(defun !cold-init-standard-readtable () - (/show0 "entering !cold-init-standard-readtable") +(defun !reader-cold-init () ;; All characters get boring defaults in MAKE-READTABLE. Now we ;; override the boring defaults on characters which need more ;; interesting behavior. @@ -542,7 +519,7 @@ (set-macro-character #\; #'read-comment) ;; (The hairier macro-character definitions, for #\# and #\`, are ;; defined elsewhere, in their own source files.) - (/show0 "leaving !cold-init-standard-readtable")) + ) ;;;; implementation of the read buffer @@ -603,7 +580,7 @@ (defun ouch-read-buffer (char buffer) ;; When buffer overflow (let ((op (token-buf-fill-ptr buffer))) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (when (>= op (length (token-buf-string buffer))) ;; an out-of-line call for the uncommon case avoids bloat. ;; Size should be doubled. @@ -626,7 +603,7 @@ ;; Retun the next character from the buffered token, or NIL. (declaim (maybe-inline token-buf-getchar)) (defun token-buf-getchar (b) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (let ((i (token-buf-cursor (truly-the token-buf b)))) (and (< i (token-buf-fill-ptr b)) (prog1 (elt (token-buf-string b) i) @@ -952,7 +929,7 @@ (declare (character closech)) (macrolet ((scan (read-a-char eofp &optional finish) `(loop (let ((char ,read-a-char)) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (cond (,eofp (error 'end-of-file :stream stream)) ((eql char closech) (return ,finish)) @@ -1174,7 +1151,7 @@ ((and (zerop (length escapes)) (eq case :upcase)) (let ((buffer (token-buf-string token-buf))) (dotimes (i (token-buf-fill-ptr token-buf)) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (setf (schar buffer i) (char-upcase (schar buffer i)))))) ((eq case :preserve)) (t @@ -1185,7 +1162,7 @@ -1 (vector-pop escapes)))) ((minusp i)) (declare (fixnum i) - (optimize (sb-c::insert-array-bounds-checks 0))) + (optimize (sb-c:insert-array-bounds-checks 0))) (if (< esc i) (let ((ch (schar buffer i))) ,@body) @@ -1665,7 +1642,7 @@ (defmacro !setq-optional-leading-sign (sign-flag token-buf rewind) ;; guaranteed to have at least one character in buffer at the start ;; or immediately following [ESFDL] marker depending on 'rewind' flag. - `(locally (declare (optimize (sb-c::insert-array-bounds-checks 0))) + `(locally (declare (optimize (sb-c:insert-array-bounds-checks 0))) (,(if rewind 'setf 'incf) (token-buf-cursor ,token-buf) (case (elt (token-buf-string ,token-buf) @@ -1955,9 +1932,6 @@ ;;;; reader initialization code -(defun !reader-cold-init () - (!cold-init-standard-readtable)) - (defmethod print-object ((readtable readtable) stream) (print-unreadable-object (readtable stream :identity t :type t))) diff -Nru sbcl-2.1.1/src/code/readtable.lisp sbcl-2.1.11/src/code/readtable.lisp --- sbcl-2.1.1/src/code/readtable.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/readtable.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -45,7 +45,7 @@ ;; Meta: there is no such function as READ-UNQUALIFIED-TOKEN. No biggie. (defconstant +char-attr-delimiter+ 14) ; (a fake for READ-UNQUALIFIED-TOKEN) -(define-load-time-global *empty-extended-char-table* nil) +(define-load-time-global *empty-extended-char-table* (make-hash-table :rehash-size 1 :test #'eq)) (sb-xc:defstruct (readtable (:conc-name nil) (:constructor make-readtable ()) diff -Nru sbcl-2.1.1/src/code/restart.lisp sbcl-2.1.11/src/code/restart.lisp --- sbcl-2.1.1/src/code/restart.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/restart.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -123,7 +123,7 @@ ;; for HANDLER-BIND ;; * MAKE-APPLY-AND-RETURN which generates TAGBODY entries executing ;; the respective BODY. - (let ((block-tag (gensym "BLOCK")) + (let ((block-tag (sb-xc:gensym "BLOCK")) (temp-var (gensym))) (labels ((parse-keywords-and-body (keywords-and-body) (do ((form keywords-and-body (cddr form)) @@ -211,7 +211,7 @@ If restart-name is not invoked, then all values returned by forms are returned. If control is transferred to this restart, it immediately returns the values NIL and T." - (let ((stream (gensym "STREAM"))) + (let ((stream (sb-xc:gensym "STREAM"))) `(restart-case ;; If there's just one body form, then don't use PROGN. This allows ;; RESTART-CASE to "see" calls to ERROR, etc. diff -Nru sbcl-2.1.1/src/code/riscv-vm.lisp sbcl-2.1.11/src/code/riscv-vm.lisp --- sbcl-2.1.1/src/code/riscv-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/riscv-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -6,6 +6,14 @@ "Return a string describing the type of the local machine." #-64-bit "RV32G" #+64-bit "RV64G") +(defun return-machine-address (scp) + ;; KLUDGE: Taken from SPARC backend. Why does `8' need to be added + ;; to the return address? Without it, backtraces get truncated and + ;; are incorrect. Are the other backends wrong as well by not adding + ;; 8? + (+ (context-register scp lip-offset) 8)) + + ;;; CONTEXT-FLOAT-REGISTER (define-alien-routine ("os_context_float_register_addr" context-float-register-addr) (* unsigned) (context (* os-context-t)) (index int)) diff -Nru sbcl-2.1.1/src/code/room.lisp sbcl-2.1.11/src/code/room.lisp --- sbcl-2.1.1/src/code/room.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/room.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -188,64 +188,8 @@ (ash header-word (- hash-slot-present-flag)) 1)))) -;;; * If symbols are 7 words incl header, as they are on 32-bit w/threads, -;;; then the part of NIL that manifests as symbol slots consumes 6 words -;;; (less the header) because NIL's symbol widetag precedes it by 1 word. -;;; So, there are 6 post-header words and 2 pre-header: one containing -;;; the widetag (not that it is ever read), and one 0 word. -;;; * If symbols are 6 words incl header, as they are on 64-bit and -;;; 32-bit w/o threads, then the symbol-like part of NIL is 5 words, -;;; which aligns up to 6, plus the two pre-header words. -;;; So either way, NIL's alignment padding makes it come out to 8 words in total. -(defconstant sizeof-nil-in-words (+ 2 (sb-int:align-up (1- sb-vm:symbol-size) 2))) - -;;; It's unclear to me whether reinventing sizetab[] in lisp is strictly -;;; an improvement over doing the obvious: -;;; (WITH-PINNED-OBJECTS (object) (alien-funcall "ext_lispboj_size" ...)) -;;; It certainly doesn't feel that it's better, but it has significantly less overhead -;;; at least on cheneygc if not also on the precise gencgc platforms. -;;; But see WITH-PINNED-OBJECT-ITERATOR in 'target-hash-table' which offers -;;; a way to mitigate the need to bind/unbind a special var when doing a massive -;;; numbers of WITH-PINNED-OBJECT operations. -(defun primitive-object-size (object) - "Return number of bytes of heap or stack directly consumed by OBJECT" - (unless (is-lisp-pointer (get-lisp-obj-address object)) - (return-from primitive-object-size 0)) - (let ((words - ;; This should pick off the most frequently-occurring things first. - ;; CONS and INSTANCE of course top the list. - (typecase object - (cons 2) - (instance (1+ (instance-length object))) - (function - (when (= (fun-subtype object) simple-fun-widetag) - (return-from primitive-object-size - (code-object-size (fun-code-header (truly-the simple-fun object))))) - (1+ (get-closure-length object))) - (code-component - (return-from primitive-object-size (code-object-size object))) - ;; Most everything else is an OTHER pointer, except for NIL. - ;; Arrays (especially strings and simple-vector) and symbols tend to be the - ;; next-most-common heap object, for which we need the ROOM-INFO. - (t - (let ((room-info (aref *room-info* (%other-pointer-widetag object)))) - (cond ((typep room-info 'specialized-array-element-type-properties) - (let ((n-data-octets (vector-n-data-octets object room-info))) - (+ (ceiling n-data-octets n-word-bytes) ; N data words - vector-data-offset))) - (t - (typecase object - (fdefn 4) ; constant length not stored in the header - ((satisfies array-header-p) - (+ array-dimensions-offset (array-rank object))) - ((simple-array nil (*)) 2) ; no payload - (null sizeof-nil-in-words) - (t - ;; GET-HEADER-DATA works for everything that's left - (1+ (logand (get-header-data object) - (room-info-mask room-info)))))))))))) - (* (align-up words 2) n-word-bytes))) - +;;; Macros not needed after this file (and avoids a redefinition warning this way) +(eval-when (:compile-toplevel) (defmacro widetag@baseptr (sap) #+big-endian `(sap-ref-8 ,sap ,(1- n-word-bytes)) #+little-endian `(sap-ref-8 ,sap 0)) @@ -254,7 +198,7 @@ `(%make-lisp-obj (logior (sap-int ,sap) (logand (deref (extern-alien "widetag_lowtag" (array char 256)) ,widetag) - lowtag-mask)))) + lowtag-mask))))) ;;; This uses the funny fixnum representation of ADDRESS. I'd like to change this ;;; to take a SAP but god forbid people are using it? @@ -302,25 +246,6 @@ #-sb-devel (aver (sap= start end))))) -;;; Test the sizing function ASAP, because if it's broken, then MAP-ALLOCATED-OBJECTS -;;; is too, and then creating the initial core will crash because of the various heap -;;; traversals performed in SAVE-LISP-AND-DIE. Don't delay a crash. -(dovector (saetp *specialized-array-element-type-properties*) - (let ((length 0) (et (saetp-specifier saetp))) - (loop (let* ((array (make-array length :element-type et)) - (size-from-lisp (primitive-object-size array)) - (size-from-c - (with-pinned-objects (array) - (alien-funcall (extern-alien "ext_lispobj_size" (function unsigned unsigned)) - (logandc2 (get-lisp-obj-address array) lowtag-mask))))) - (unless (= size-from-lisp size-from-c) - (bug "size calculation mismatch on ~S" array)) - ;; Stop after enough trials to hit all the edge case - (when (or (>= size-from-lisp (* 8 sb-vm:n-word-bytes)) - (and (eq et nil) (>= length 4))) ; always 2 words - (return)) - (incf length))))) - ;;; Access to the GENCGC page table for better precision in ;;; MAP-ALLOCATED-OBJECTS #+gencgc @@ -562,14 +487,14 @@ #+gencgc (let ((region-struct #+sb-thread (sap+ (sb-thread::current-thread-sap) - (ash thread-alloc-region-slot word-shift)) + (ash thread-boxed-tlab-slot word-shift)) ;; If no threads, the alloc_region struct is in static space. #-sb-thread (int-sap boxed-region))) ;; The 'start_addr' field is at word index 3 of the structure (see gencgc-alloc-region.h). (unless (eql (sap-ref-word region-struct (ash 3 word-shift)) 0) (alien-funcall (extern-alien "gc_close_region" (function void system-area-pointer int)) region-struct - 1)) + 1)) ; ASSUMPTION: BOXED_PAGE_FLAG = 1 nil)) ;;;; MEMORY-USAGE @@ -777,9 +702,9 @@ (eql type funcallable-instance-widetag)) (incf total-objects) (let* ((layout (if (eql type funcallable-instance-widetag) - (%fun-layout obj) - (%instance-layout obj))) - (classoid (layout-classoid layout)) + (%fun-wrapper obj) + (%instance-wrapper obj))) + (classoid (wrapper-classoid layout)) (found (ensure-gethash classoid totals (cons 0 0))) (size size)) (declare (fixnum size)) @@ -1049,12 +974,9 @@ ;; These two are in fact generally the most frequently occurring type. ,.(make-case 'cons `(car ,obj) `(cdr ,obj)) ,.(make-case* 'instance - `(let ((.l. (%instance-layout ,obj))) - ;; Though we've bound %INSTANCE-LAYOUT to a variable, - ;; pass the form %INSTANCE-LAYOUT to functoid - ;; in case it wants to examine the form + `(progn (,functoid (%instance-layout ,obj) ,@more) - (do-instance-tagged-slot (.i. ,obj :layout .l. :pad nil) + (do-instance-tagged-slot (.i. ,obj nil) (,functoid (%instance-ref ,obj .i.) ,@more)))) (function (typecase ,obj @@ -1066,7 +988,7 @@ ;; if functoid is a macro that does nothing. (,functoid .o. ,@more))) ,.(make-case* 'funcallable-instance - `(let ((.l. (%fun-layout ,obj))) + `(progn ;; As for INSTANCE, allow the functoid to see the access form (,functoid (%fun-layout ,obj) ,@more) (,functoid (%funcallable-instance-fun ,obj) ,@more) @@ -1076,7 +998,7 @@ ;; both tricky and unnecessary to generalize iteration. ;; So just hardcode the few cases that exist. #+compact-instance-header - (ecase (layout-bitmap .l.) + (ecase (wrapper-bitmap (%fun-wrapper ,obj)) (-1 ; external trampoline, all slots are tagged ;; In this case, the trampoline word is scanned, with no ill effect. (loop for .i. from 0 @@ -1090,7 +1012,7 @@ (,functoid (%funcallable-instance-info ,obj 0) ,@more))) #-compact-instance-header (progn - (aver (eql (layout-bitmap .l.) -4)) + (aver (eql (wrapper-bitmap (%fun-wrapper ,obj)) -4)) ;; v ----trampoline ;; = #b1...1100 ;; ^----- layout @@ -1117,7 +1039,7 @@ ,.(make-case 'array) ,.(make-case* 'symbol `(,functoid (%primitive sb-c:fast-symbol-global-value ,obj) ,@more) - `(,functoid (symbol-info ,obj) ,@more) + `(,functoid (symbol-%info ,obj) ,@more) `(,functoid (symbol-name ,obj) ,@more) `(,functoid (symbol-package ,obj) ,@more) `(when (symbol-extra-slot-p ,obj) @@ -1160,6 +1082,7 @@ ;;; code-components are considered to reference their embedded ;;; simple-funs for this purpose; if THIS is a simple-fun, it is ignored. (defun references-p (this that) + (declare (optimize (sb-c::aref-trapping 0))) (macrolet ((test (x) `(when (eq ,x that) (go win)))) (tagbody (do-referenced-object (this test) @@ -1274,7 +1197,8 @@ &aux (n-code-bytes 0) (total-pages next-free-page) (pages - (make-array total-pages :element-type 'bit))) + (make-array total-pages :element-type 'bit + :initial-element 0))) (flet ((dump-page (page-num) (format stream "~&Page ~D~%" page-num) (let ((where (+ dynamic-space-start (* page-num gencgc-card-bytes))) @@ -1334,17 +1258,18 @@ #+gencgc (defun generation-of (object) - (let* ((addr (get-lisp-obj-address object)) - (page (find-page-index addr))) - (cond ((>= page 0) (slot (deref page-table page) 'gen)) - #+immobile-space - ((immobile-space-addr-p addr) - ;; SIMPLE-FUNs don't contain a generation byte - (when (simple-fun-p object) - (setq addr (get-lisp-obj-address (fun-code-header object)))) - (let ((sap (int-sap (logandc2 addr lowtag-mask)))) - (logand (if (fdefn-p object) (sap-ref-8 sap 1) (sap-ref-8 sap 3)) - #xF)))))) + (with-pinned-objects (object) + (let* ((addr (get-lisp-obj-address object)) + (page (find-page-index addr))) + (cond ((>= page 0) (slot (deref page-table page) 'gen)) + #+immobile-space + ((immobile-space-addr-p addr) + ;; SIMPLE-FUNs don't contain a generation byte + (when (simple-fun-p object) + (setq addr (get-lisp-obj-address (fun-code-header object)))) + (let ((sap (int-sap (logandc2 addr lowtag-mask)))) + (logand (if (fdefn-p object) (sap-ref-8 sap 1) (sap-ref-8 sap 3)) + #xF))))))) ;;; Show objects in a much simpler way than print-allocated-objects. ;;; Probably don't use this for generation 0 of dynamic space. Other spaces are ok. @@ -1362,9 +1287,12 @@ ;;; Unfortunately this is a near total copy of the test in gc.impure.lisp (defun !ensure-genesis-code/data-separation () #+gencgc - (let* ((n-bits (+ next-free-page 10)) - (code-bits (make-array n-bits :element-type 'bit)) - (data-bits (make-array n-bits :element-type 'bit)) + (let* ((n-bits + (progn + (sb-vm::close-current-gc-region) + (+ next-free-page 50))) + (code-bits (make-array n-bits :element-type 'bit :initial-element 0)) + (data-bits (make-array n-bits :element-type 'bit :initial-element 0)) (total-code-size 0)) (map-allocated-objects (lambda (obj type size) @@ -1472,28 +1400,38 @@ (+ start sb-vm:gencgc-card-bytes))) (map-objects-in-range #'print-it (%make-lisp-obj start) (%make-lisp-obj end))))) -(defun code-from-serialno (serial) - (dx-flet ((visit (obj type size) +(defun map-code-objects (fun) + (dx-flet ((filter (obj type size) (declare (ignore size)) - #+gencgc (aver (= type sb-vm:code-header-widetag)) - (when (= (%code-serialno obj) serial) - (return-from code-from-serialno obj)))) - #+cheneygc (map-allocated-objects #'visit :all) + (when (= type sb-vm:code-header-widetag) + (funcall fun obj))) + (nofilter (obj type size) + (declare (ignore type size)) + (funcall fun obj))) + #+cheneygc (map-allocated-objects #'filter :all) #+gencgc - (progn + (without-gcing #+immobile-code - (map-objects-in-range #'visit + (map-objects-in-range #'nofilter (ash varyobj-space-start (- n-fixnum-tag-bits)) (%make-lisp-obj (sap-int *varyobj-space-free-pointer*))) - (walk-dynamic-space #'visit + (alien-funcall (extern-alien "close_code_region" (function void))) + (walk-dynamic-space #'nofilter #b1111111 ; all generations 3 3)))) +(export 'code-from-serialno) +(defun code-from-serialno (serial) + (dx-flet ((visit (obj) + (when (= (%code-serialno obj) serial) + (return-from code-from-serialno obj)))) + (map-code-objects #'visit))) + (defun show-all-layouts () - (let ((l (sb-vm::list-allocated-objects :all :test #'sb-kernel::layout-p)) + (let ((l (sb-vm::list-allocated-objects :all :test #'sb-kernel::wrapper-p)) zero trailing-raw trailing-tagged vanilla) (dolist (x l) - (let ((m (sb-kernel::layout-bitmap x))) + (let ((m (wrapper-bitmap x))) (cond ((eql m +layout-all-tagged+) (push x vanilla)) ((eql m 0) (push x zero)) ((minusp m) (push x trailing-tagged)) @@ -1501,42 +1439,51 @@ (flet ((legend (newline str list) (when newline (terpri)) (let ((s (format nil str (length list)))) - (format t "~A~%~A~%" s (make-string (length s) :initial-element #\-)))) - (name (x) (classoid-name (layout-classoid x)))) + (format t "~A~%~A~%" s (make-string (length s) :initial-element #\-))))) (when zero (legend nil "Zero bitmap (~d):" zero) - (dolist (x zero) (format t "~a~%" (name x)))) + (dolist (x zero) (format t "~a~%" (wrapper-classoid-name x)))) (when trailing-raw (legend t "Trailing raw (~d):" trailing-raw) (dolist (x trailing-raw) - (let ((m (sb-kernel::layout-bitmap x))) + (let ((m (wrapper-bitmap x))) (format t "~30a 0...~v,'0b~%" - (name x) - (acond ((layout-info x) (1+ (dd-length it))) (t 32)) + (wrapper-classoid-name x) + (acond ((wrapper-info x) (1+ (dd-length it))) (t 32)) m)))) (when trailing-tagged (legend t "Trailing tagged (~d):" trailing-tagged) (dolist (x trailing-tagged) - (let ((m (sb-kernel::layout-bitmap x))) + (let ((m (wrapper-bitmap x))) (format t "~30a 1...~b~%" - (name x) - (acond ((layout-info x) (ldb (byte (dd-length it) 0) m)) + (wrapper-classoid-name x) + (acond ((wrapper-info x) (ldb (byte (dd-length it) 0) m)) (t (ldb (byte 32 0) m))))))) (legend t "Default: (~d) [not shown]" vanilla)))) +#+ubsan +(defun find-poisoned-vectors (&aux result) + (dolist (v (sb-vm:list-allocated-objects :all :type sb-vm:simple-vector-widetag) + result) + (when (dotimes (i (length v)) + (declare (optimize (sb-c::aref-trapping 0))) + (let ((val (svref v i))) + (when (= (get-lisp-obj-address val) no-tls-value-marker-widetag) + (return t)))) + (push (make-weak-pointer v) result) + (let* ((origin (vector-extra-data v)) + (code (sb-di::code-header-from-pc (ash origin -3))) + (*print-array* nil)) + (format t "g~d ~a ~a~%" (sb-kernel:generation-of v) v code))))) + (in-package "SB-C") ;;; As soon as practical in warm build it makes sense to add -;;; cold-allocation-point-fixups into the weak hash-table. +;;; cold-allocation-patch-points into the weak hash-table. ;;; FIXME: I suspect that this wants to be just a weak vector ;;; (all code objects that have any allocation profiling compiled in), ;;; and not a hash-table, and that the list of fixups in the component ;;; can be attached to the debug info (in the manner of debug funs). ;;; When this was first implemented, weak-vectors weren't a thing. Maybe? -(defvar *!cold-allocation-point-fixups*) -(let ((hash-table (make-hash-table :test 'eq))) - ;; Group by code component - (loop for (code . offset) across *!cold-allocation-point-fixups* - do (push offset (gethash code hash-table))) - (dohash ((code list) hash-table) - (setf (gethash code *allocation-point-fixups*) - (convert-alloc-point-fixups code list)))) +(defvar *!cold-allocation-patch-point*) +(loop for (code . points) in *!cold-allocation-patch-point* + do (setf (gethash code *allocation-patch-points*) points)) diff -Nru sbcl-2.1.1/src/code/run-program.lisp sbcl-2.1.11/src/code/run-program.lisp --- sbcl-2.1.1/src/code/run-program.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/run-program.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -307,7 +307,8 @@ "Hand SIGNAL to PROCESS. If WHOM is :PID, use the kill Unix system call. If WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is :PTY-PROCESS-GROUP deliver the signal to whichever process group is - currently in the foreground." + currently in the foreground. + Returns T if successful, otherwise returns NIL and error number (two values)." (let ((pid (ecase whom ((:pid :process-group) (process-pid process)) @@ -543,7 +544,10 @@ ;; Copy string. (copy-ub8-to-system-area octets 0 string-sap 0 size) ;; NULL-terminate it - (system-area-ub8-fill 0 string-sap size 4) + ;; (As it says up top: "assume 4 byte is enough for everyone.") + (let ((sap (sap+ string-sap size))) + (setf (sap-ref-8 sap 0) 0 (sap-ref-8 sap 1) 0 + (sap-ref-8 sap 2) 0 (sap-ref-8 sap 3) 0)) ;; Put the pointer in the vector. (setf (sap-ref-sap vec-sap vec-index-offset) string-sap) ;; Advance string-sap for the next string. @@ -1323,11 +1327,15 @@ if not available." (or sb-sys::*software-version* (setf sb-sys::*software-version* - (string-trim '(#\newline) - (%with-output-to-string (stream) + (possibly-base-stringize + #+linux + (with-open-file (f "/proc/sys/kernel/osrelease") (read-line f)) + #-linux + (string-trim '(#\newline) + (%with-output-to-string (stream) (run-program "/bin/uname" ;; "-r" on haiku just prints "1" ;; but "-v" prints some detail. #+haiku '("-v") #-haiku '("-r") - :output stream)))))) + :output stream))))))) diff -Nru sbcl-2.1.1/src/code/save.lisp sbcl-2.1.11/src/code/save.lisp --- sbcl-2.1.1/src/code/save.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/save.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -80,16 +80,22 @@ sb-thread::*session* sb-kernel::*gc-epoch*)) -(defun start-lisp (toplevel) +(defun start-lisp (toplevel callable-exports) (named-lambda start-lisp () - (handling-end-of-the-world - (reinit t) - (funcall toplevel)))) + (cond (callable-exports + (reinit t) + (dolist (export callable-exports) + (sb-alien::initialize-alien-callable-symbol export))) + (t + (handling-end-of-the-world + (reinit t) + (funcall toplevel)))))) (defun save-lisp-and-die (core-file-name &key - (toplevel #'toplevel-init) + (toplevel #'toplevel-init toplevel-supplied) (executable nil) (save-runtime-options nil) + (callable-exports ()) (purify t) (root-structures ()) (environment-name "auxiliary") @@ -125,6 +131,13 @@ all command line arguments to be passed to the toplevel. Meaningless if :EXECUTABLE is NIL. + :CALLABLE-EXPORTS + This should be a list of symbols to be initialized to the + appropriate alien callables on startup. All exported symbols should + be present as global symbols in the symbol table of the runtime + before the saved core is loaded. When this list is non-empty, the + :TOPLEVEL argument cannot be supplied. + :PURIFY If true (the default on cheneygc), do a purifying GC which moves all dynamically allocated objects into static space. This takes @@ -194,6 +207,8 @@ (declare (ignore environment-name)) #+gencgc (declare (ignore purify) (ignorable root-structures)) + (when (and callable-exports toplevel-supplied) + (error ":TOPLEVEL cannot be supplied when there are callable exports.")) ;; If the toplevel function is not defined, this will signal an ;; error before saving, not at startup time. (let ((toplevel (%coerce-callable-to-fun toplevel)) @@ -217,7 +232,7 @@ (if value 1 0))) (let ((name (native-namestring (physicalize-pathname core-file-name) :as-file t)) - (startfun (start-lisp toplevel))) + (startfun (start-lisp toplevel callable-exports))) (deinit) ;; FIXME: Would it be possible to unmix the PURIFY logic from this ;; function, and just do a GC :FULL T here? (Then if the user wanted @@ -298,8 +313,7 @@ (defun deinit () (call-hooks "save" *save-hooks*) - #+sb-wtimer - (itimer-emulation-deinit) + #+win32 (itimer-emulation-deinit) #+sb-thread (let (err) (with-system-mutex (sb-thread::*make-thread-lock*) @@ -317,7 +331,9 @@ (make-condition 'save-with-multiple-threads-error :interactive-threads interactive :other-threads other))))) - (when err (error err))) + (when err (error err)) + #+allocator-metrics (setq sb-thread::*allocator-metrics* nil) + (setq sb-thread::*sprof-data* nil)) (tune-image-for-dump) (float-deinit) (profile-deinit) @@ -366,6 +382,7 @@ ;;; Doing too much consing within MAP-ALLOCATED-OBJECTS can lead to heap ;;; exhaustion (due to inhibited GC), so this takes several passes. (defun coalesce-ctypes (&optional verbose) + (declare (optimize (sb-c::aref-trapping 0))) (let* ((table (make-hash-table :test 'equal)) interned-ctypes referencing-objects) @@ -445,6 +462,7 @@ (%set-symbol-global-value obj (coalesce part))))) ((not (memq accessor '(%closure-fun + %fun-layout %instance-layout symbol-package symbol-name fdefn-name %numerator %denominator %realpart %imagpart @@ -524,8 +542,7 @@ (cond ((not foundp) (setf (gethash name name-ht) name)) ((neq name new) - (setf (%instance-ref debug-fun - (get-dsd-index compiled-debug-fun name)) + (%instance-set debug-fun (get-dsd-index compiled-debug-fun name) new)))) while next)) (sb-lockless::linked-list @@ -563,7 +580,7 @@ result)) (pushnew (code-from-fun fun) result))))))) (code-from-fun (fun) - (ecase (fun-subtype fun) + (ecase (%fun-pointer-widetag fun) (#.simple-fun-widetag (fun-code-header fun)) (#.funcallable-instance-widetag diff -Nru sbcl-2.1.1/src/code/seq.lisp sbcl-2.1.11/src/code/seq.lisp --- sbcl-2.1.1/src/code/seq.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/seq.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -190,6 +190,12 @@ (sb-c::%type-check-error/c ,sequence 'sb-kernel::object-not-sequence-error nil))))))) +(defmacro make-vector-like (vector length poison) + (declare (ignorable poison)) + `(let ((type (array-underlying-widetag ,vector))) + (sb-vm::allocate-vector-with-widetag + #+ubsan ,poison type ,length (aref sb-vm::%%simple-array-n-bits-shifts%% type)))) + ;;; Like SEQ-DISPATCH-CHECKING, but also assert that OTHER-FORM produces ;;; a sequence. This assumes that the containing function declares its ;;; result to be explicitly checked, @@ -203,7 +209,7 @@ "Return a sequence of the same type as SEQUENCE and the given LENGTH." `(seq-dispatch ,sequence (make-list ,length) - (make-vector-like ,sequence ,length) + (make-vector-like ,sequence ,length t) (sb-sequence:make-sequence-like ,sequence ,length))) (defun bad-sequence-type-error (type-spec) @@ -362,7 +368,7 @@ (car list))) (declare (type index count))) (locally - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (when (>= index (length sequence)) (signal-index-too-large-error sequence index)) (aref sequence index)) @@ -470,6 +476,12 @@ ;;;; SUBSEQ ;;;; +;;; FIXME: surely we can emit tighter code by not having 16 copies of the +;;; vector allocator buried inside this (and similar) functions. +;;; Instead there can be a size calculation up front, then ALLOCATE-VECTOR +;;; with the underlying widetag, then perform an N-way dispatch for the copy. +;;; Also, there should only be as many different ways to copy +;;; as there are different element sizes. (!define-array-dispatch :jump-table vector-subseq-dispatch (array start end) (declare (optimize speed (safety 0))) (declare (type index start end)) @@ -603,7 +615,8 @@ do (setf pointer (cdr (rplaca pointer item))))))) sequence) -(define-load-time-global %%fill-bashers%% (make-array (1+ sb-vm:widetag-mask))) +(define-load-time-global %%fill-bashers%% (make-array (1+ sb-vm:widetag-mask) + :initial-element 0)) #.`(progn ,@(loop for saetp across sb-vm:*specialized-array-element-type-properties* for et = (sb-vm:saetp-specifier saetp) @@ -709,55 +722,53 @@ collect `(eq ,tag ,(sb-vm:saetp-typecode saetp))))) ;;;; REPLACE -(defun vector-replace (vector1 vector2 start1 start2 end1 diff) - (declare ((or (eql -1) index) start1 start2 end1) - (optimize (sb-c::insert-array-bounds-checks 0)) - ((integer -1 1) diff)) - (let ((tag1 (%other-pointer-widetag vector1)) - (tag2 (%other-pointer-widetag vector2))) - (macrolet ((copy (&body body) - `(do ((index1 start1 (+ index1 diff)) - (index2 start2 (+ index2 diff))) - ((= index1 end1)) - (declare (fixnum index1 index2)) - ,@body))) - (cond ((= tag1 tag2 sb-vm:simple-vector-widetag) - (copy - (setf (svref vector1 index1) (svref vector2 index2)))) - ;; TODO: can do the same with small specialized arrays - ((and (= tag1 tag2) - (word-specialized-vector-tag-p tag1)) - (copy - (setf (%vector-raw-bits vector1 index1) - (%vector-raw-bits vector2 index2)))) - (t - (let ((getter (the function (svref %%data-vector-reffers%% tag2))) - (setter (the function (svref %%data-vector-setters%% tag1)))) - (copy - (funcall setter vector1 index1 - (funcall getter vector2 index2)))))))) - vector1) ;;; If we are copying around in the same vector, be careful not to copy the ;;; same elements over repeatedly. We do this by copying backwards. +;;; Bounding indices were checked for validity by DEFINE-SEQUENCE-TRAVERSER. (defmacro vector-replace-from-vector () - `(let ((nelts (min (- target-end target-start) - (- source-end source-start)))) - (with-array-data ((data1 target-sequence) (start1 target-start) (end1)) - (declare (ignore end1)) - (let ((end1 (the fixnum (+ start1 nelts)))) - (if (and (eq target-sequence source-sequence) - (> target-start source-start)) - (let ((end (the fixnum (1- end1)))) - (vector-replace data1 data1 - end - (the fixnum (- end - (- target-start source-start))) - (1- start1) - -1)) - (with-array-data ((data2 source-sequence) (start2 source-start) (end2)) - (declare (ignore end2)) - (vector-replace data1 data2 start1 start2 end1 1))))) + `(locally + (declare (optimize (safety 0))) + (let ((nelts (min (- target-end target-start) + (- source-end source-start)))) + (when (plusp nelts) + (with-array-data ((data1 target-sequence) (start1 target-start) (end1)) + (progn end1) + (with-array-data ((data2 source-sequence) (start2 source-start) (end2)) + (progn end2) + (let ((tag1 (%other-pointer-widetag data1)) + (tag2 (%other-pointer-widetag data2))) + (block replace + (when (= tag1 tag2) + (when (= tag1 sb-vm:simple-vector-widetag) ; rely on the transform + (replace (truly-the simple-vector data1) + (truly-the simple-vector data2) + :start1 start1 :end1 (truly-the index (+ start1 nelts)) + :start2 start2 :end2 (truly-the index (+ start2 nelts))) + (return-from replace)) + (let ((copier (sb-vm::blt-copier-for-widetag tag1))) + (when (functionp copier) + ;; these copiers figure out which direction to step. + ;; arg order is FROM, TO which is the opposite of REPLACE. + (funcall copier data2 start2 data1 start1 nelts) + (return-from replace)))) + ;; General case is just like the code emitted by TRANSFORM-REPLACE + ;; but using the getter and setter. + (let ((getter (the function (svref %%data-vector-reffers%% tag2))) + (setter (the function (svref %%data-vector-setters%% tag1)))) + (cond ((and (eq data1 data2) (> start1 start2)) + (do ((i (the (or (eql -1) index) (+ start1 nelts -1)) (1- i)) + (j (the (or (eql -1) index) (+ start2 nelts -1)) (1- j))) + ((< i start1)) + (declare (index i j)) + (funcall setter data1 i (funcall getter data2 j)))) + (t + (do ((i start1 (1+ i)) + (j start2 (1+ j)) + (end (the index (+ start1 nelts)))) + ((>= i end)) + (declare (index i j)) + (funcall setter data1 i (funcall getter data2 j)))))))))))) target-sequence)) (defmacro list-replace-from-list () @@ -810,50 +821,12 @@ (declare (fixnum target-index source-index)) (setf (aref target-sequence target-index) (car source-sequence)))) -;;;; The support routines for REPLACE are used by compiler transforms, so we -;;;; worry about dealing with END being supplied or defaulting to NIL -;;;; at this level. - -(defun list-replace-from-list* (target-sequence source-sequence target-start - target-end source-start source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (list-replace-from-list)) - -(defun list-replace-from-vector* (target-sequence source-sequence target-start - target-end source-start source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (list-replace-from-vector)) - -(defun vector-replace-from-list* (target-sequence source-sequence target-start - target-end source-start source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (vector-replace-from-list)) - -(defun vector-replace-from-vector* (target-sequence source-sequence - target-start target-end source-start - source-end) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (vector-replace-from-vector)) - -#+sb-unicode -(defun simple-character-string-replace-from-simple-character-string* - (target-sequence source-sequence - target-start target-end source-start source-end) - (declare (type (simple-array character (*)) target-sequence source-sequence)) - (when (null target-end) (setq target-end (length target-sequence))) - (when (null source-end) (setq source-end (length source-sequence))) - (vector-replace-from-vector)) - (define-sequence-traverser replace (target-sequence1 source-sequence2 &rest args &key start1 end1 start2 end2) "Destructively modifies SEQUENCE1 by copying successive elements into it from the SEQUENCE2. -Elements are copied to the subseqeuence bounded by START1 and END1, +Elements are copied to the subsequence bounded by START1 and END1, from the subsequence bounded by START2 and END2. If these subsequences are not of the same length, then the shorter length determines how many elements are copied." @@ -926,7 +899,9 @@ :check-fill-pointer t) (declare (ignore start)) (let* ((tag (%other-pointer-widetag vector)) - (new-vector (sb-vm::allocate-vector-with-widetag tag length nil))) + (new-vector (sb-vm::allocate-vector-with-widetag + #+ubsan nil tag length + (aref sb-vm::%%simple-array-n-bits-shifts%% tag)))) (cond ((= tag sb-vm:simple-vector-widetag) (do ((left-index 0 (1+ left-index)) (right-index end)) @@ -1117,7 +1092,7 @@ (macrolet ((def (name element-type &rest dispatch) `(defun ,name (&rest sequences) (declare (explicit-check) - (optimize (sb-c::insert-array-bounds-checks 0))) + (optimize (sb-c:insert-array-bounds-checks 0))) (let ((length 0)) (declare (index length)) (do-rest-arg ((seq) sequences) @@ -1154,9 +1129,11 @@ (declare (index length)) (do-rest-arg ((seq) sequences) (incf length (length seq))) - (let ((result (sb-vm::allocate-vector-with-widetag widetag length nil)) - (setter (the function (svref %%data-vector-setters%% widetag))) - (index 0)) + (let* ((n-bits-shift (aref sb-vm::%%simple-array-n-bits-shifts%% widetag)) + (result (sb-vm::allocate-vector-with-widetag + #+ubsan nil widetag length n-bits-shift)) + (setter (the function (svref %%data-vector-setters%% widetag))) + (index 0)) (declare (index index)) (do-rest-arg ((seq) sequences) (sb-sequence:dosequence (e seq) @@ -1246,7 +1223,7 @@ (progn (setf (car in-apply-args) (funcall elt s state)) (setf (caar in-iters) (funcall step s state from-end))))))))))))) -#-sb-devel + (declaim (start-block map %map)) (defun %map-to-list (fun sequences) @@ -2205,7 +2182,7 @@ start end count key test test-not old) (declare (fixnum start count end incrementer right) (type (or null function) key)) - (let* ((result (make-vector-like sequence length)) + (let* ((result (make-vector-like sequence length nil)) (getter (the function (svref %%data-vector-reffers%% (%other-pointer-widetag sequence)))) (setter (the function (svref %%data-vector-setters%% diff -Nru sbcl-2.1.1/src/code/serve-event.lisp sbcl-2.1.11/src/code/serve-event.lisp --- sbcl-2.1.1/src/code/serve-event.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/serve-event.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -192,7 +192,6 @@ ;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends -#-sb-devel (declaim (start-block wait-until-fd-usable serve-event serve-all-events compute-pollfds)) ;;; When a *periodic-polling-function* is defined the server will not @@ -260,7 +259,7 @@ (+ (* 1000 to-sec) (truncate to-usec 1000)) -1) when (or #+win32 (eq direction :output) - #+win32 (sb-win32:handle-listen fd) + #+win32 (sb-win32:handle-listen fd (or to-sec 0) (or to-usec 0)) #-win32 (sb-unix:unix-simple-poll fd direction to-msec)) do (return-from wait-until-fd-usable t) diff -Nru sbcl-2.1.1/src/code/setf-funs.lisp sbcl-2.1.11/src/code/setf-funs.lisp --- sbcl-2.1.1/src/code/setf-funs.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/setf-funs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,10 +14,18 @@ (eval-when (:compile-toplevel :execute) +(defun c*r-function-p (string) + (and (char= (char string 0) #\C) + (char= (char string (1- (length string))) #\R) + (loop for i from 1 below (1- (length string)) + always (member (char string i) '(#\A #\D))))) + (defun compute-one-setter (name type) (let ((args (second type))) (cond ((null (intersection args lambda-list-keywords)) + (when (c*r-function-p (string name)) + (setq args '(cons))) (let ((res (type-specifier (single-value-type (values-specifier-type (third type))))) diff -Nru sbcl-2.1.1/src/code/setf.lisp sbcl-2.1.11/src/code/setf.lisp --- sbcl-2.1.1/src/code/setf.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/setf.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -76,12 +76,18 @@ (let ((fname (car form))) ;; Local functions inhibit global SETF methods. (unless (sb-c::fun-locally-defined-p fname environment) + ;; There are 3 possibilities for the expander: + ;; # - define-setf-expander + ;; (symbol doc . source-loc) - defsetf short form + ;; (integer . #) - defsetf long form (awhen (info :setf :expander fname) (return-from retry (typecase it - (symbol ; short DEFSETF - (call `(,it) (lambda (new args) `(,@args ,new)))) - (list ; long DEFSETF + (function ; DEFINE-SETF-EXPANDER + (funcall it form environment)) + ((cons symbol) ; short form DEFSETF + (call `(,(car it)) (lambda (new args) `(,@args ,new)))) + (t ; long form DEFSETF (binding* ((newvals (newvals (car it))) (expander (the function (cdr it))) ((tempvars tempvals call-args) @@ -91,18 +97,14 @@ (or #+sb-xc (%fun-lambda-list expander))))) (values tempvars tempvals newvals (apply expander call-args environment newvals) - `(,fname ,@call-args)))) - ;; DEFINE-SETF-EXPANDER - (function (funcall it form environment))))) + `(,fname ,@call-args))))))) (awhen (transformable-struct-setf-p form environment) (let ((instance (make-symbol "OBJ")) (vals (newvals 1))) (return-from retry (values (list instance) (list (cadr form)) vals - (slot-access-transform - :setf (list instance (car vals)) it) - (slot-access-transform - :read (list instance) it)))))) + (slot-access-transform :setf (list instance (car vals)) it) + (slot-access-transform :read (list instance) it)))))) (multiple-value-bind (expansion expanded) (%macroexpand-1 form environment) (if expanded @@ -178,12 +180,11 @@ ;; NIL is not a valid setf inverse name, for two reasons: ;; 1. you can't define a function named NIL, ;; 2. (DEFSETF THING () ...) is the long form DEFSETF syntax. - (when (typep inverse '(and symbol (not null))) - (return-from setf `(,inverse ,@(cdr place) ,value-form)))) + (when (typep inverse '(cons symbol)) + (return-from setf `(,(car inverse) ,@(cdr place) ,value-form)))) (awhen (transformable-struct-setf-p place env) (return-from setf - (slot-access-transform - :setf (list (cadr place) value-form) it))))) + (slot-access-transform :setf (list (cadr place) value-form) it))))) (multiple-value-bind (temps vals newval setter) (get-setf-expansion place env) @@ -418,8 +419,7 @@ ;;;; DEFSETF ;;; Assign SETF macro information for NAME, making all appropriate checks. -(defun %defsetf (name expander &optional doc) - (declare (ignorable doc)) +(defun %defsetf (name expander) (with-single-package-locked-error (:symbol name "defining a setf-expander for ~A")) (let ((setf-fn-name `(setf ,name))) @@ -449,9 +449,6 @@ (style-warn "defining setf macro for ~S when ~S is also defined" name setf-fn-name))))) (setf (info :setf :expander name) expander) - #-sb-xc-host - (when doc - (setf (documentation name 'setf) doc)) name) ;;; This is pretty broken if there are keyword arguments (lp#1452947) @@ -464,7 +461,8 @@ (typecase rest ((cons (and symbol (not null)) (or null (cons string null))) `(eval-when (:load-toplevel :compile-toplevel :execute) - (%defsetf ',access-fn ',(car rest) ,@(cdr rest)))) + (%defsetf ',access-fn + (list* ',(car rest) ,(cadr rest) (sb-c:source-location))))) ((cons list (cons list)) (destructuring-bind (lambda-list (&rest stores) &body body) rest (binding* (((llks req opt rest key aux env) @@ -484,15 +482,14 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) (%defsetf ',access-fn (cons ,(length stores) - (named-lambda (%defsetf ,access-fn) - (,subforms ,env-var ,@stores) + (named-lambda (%defsetf ,access-fn) (,subforms ,env-var ,@stores) (declare (sb-c::lambda-list ,lambda-list)) + ,@(if doc (list doc)) ,@(if outer-decls (list outer-decls)) ,@(unless env `((declare (ignore ,env-var)))) (apply (lambda ,lambda-list ,@inner-decls (block ,access-fn ,@forms)) - ,subforms))) - ,@(and doc `(,doc))))))) + ,subforms)))))))) (t (error "Ill-formed DEFSETF for ~S" access-fn)))) @@ -507,7 +504,8 @@ ;; (defun collect-setf-temps (sexprs environment name-hints) (labels ((next-name-hint () - (let ((sym (pop name-hints))) ; OK if list was nil + ;; OK if list was nil or :UNKNOWN + (let ((sym (and (listp name-hints) (pop name-hints)))) (case sym (&optional (next-name-hint)) ((&key &rest) (setq name-hints nil)) @@ -578,13 +576,8 @@ "Syntax like DEFMACRO, but creates a setf expander function. The body of the definition must be a form that returns five appropriate values." (check-designator access-fn define-setf-expander "access-function") - (multiple-value-bind (def doc) - ;; Perhaps it would be more elegant to keep the docstring attached - ;; to the expander function, as for CAS? - (make-macro-lambda `(setf-expander ,access-fn) lambda-list body - 'define-setf-expander access-fn - :doc-string-allowed :external) - ;; Maybe kill docstring, but only under the cross-compiler. - #+(and (not sb-doc) sb-xc-host) (setq doc nil) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (%defsetf ',access-fn ,def ,@(and doc `(,doc)))))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%defsetf ',access-fn + ,(make-macro-lambda `(setf-expander ,access-fn) lambda-list body + 'define-setf-expander access-fn + :doc-string-allowed :internal)))) diff -Nru sbcl-2.1.1/src/code/share-vm.lisp sbcl-2.1.11/src/code/share-vm.lisp --- sbcl-2.1.1/src/code/share-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/share-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -55,9 +55,7 @@ ;; the pointer in order to read the lower half. This has been broken ;; at least twice in the past. MIPS also appears to be the ONLY ;; system for which the signal context field size may differ from -;; n-word-bits (well, and ALPHA, but that's a separate matter), but -;; this entire thing will likely need to be revisited when we add x32 -;; or n32 ABI support. +;; n-word-bits. (defconstant kludge-big-endian-short-pointer-offset (+ 0 #+(and mips big-endian (not 64-bit)) 1)) diff -Nru sbcl-2.1.1/src/code/sharpm.lisp sbcl-2.1.11/src/code/sharpm.lisp --- sbcl-2.1.1/src/code/sharpm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/sharpm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -49,42 +49,33 @@ (defun sharp-star (stream ignore numarg) (declare (ignore ignore)) (declare (type (or null integer) numarg)) - (binding* (((buffer escape-appearedp) (read-extended-token stream)) + (binding* (((buffer escaped) (read-extended-token stream)) (input-len (token-buf-fill-ptr buffer)) (bstring (token-buf-string buffer))) - (cond (*read-suppress* nil) - (escape-appearedp - (simple-reader-error stream - "An escape character appeared after #*.")) - ((and numarg (zerop input-len) (not (zerop numarg))) - (simple-reader-error - stream - "You have to give a little bit for non-zero #* bit-vectors.")) - ((or (null numarg) (>= numarg input-len)) - (do ((bvec - (make-array (or numarg input-len) - :element-type 'bit - :initial-element - (if (and (plusp input-len) - (char= (char bstring (1- input-len)) #\1)) - 1 0))) - (i 0 (1+ i))) - ((= i input-len) bvec) - (declare (index i) (optimize (sb-c::insert-array-bounds-checks 0))) - (let ((char (char bstring i))) - (setf (elt bvec i) - (case char - (#\0 0) - (#\1 1) - (t (simple-reader-error - stream "illegal element given for bit-vector: ~S" - char))))))) - (t - (simple-reader-error - stream - "Bit vector is longer than specified length #~A*~A" - numarg - (copy-token-buf-string buffer)))))) + (when *read-suppress* (return-from sharp-star nil)) + (when escaped (simple-reader-error stream "An escape character appeared after #*.")) + (when numarg + (cond ((and (not (eql numarg 0)) (zerop input-len)) + (simple-reader-error + stream "#~D* requires at least 1 bit of input." numarg)) + ((> input-len numarg) + (simple-reader-error + stream "Too many bits in ~S: expected ~D or fewer" + (copy-token-buf-string buffer) numarg))) + (when (eql numarg 0) (setq numarg nil))) + (let* ((fill (if numarg (logand (char-code (char bstring (1- input-len))) 1) 0)) + (bvec (make-array (or numarg input-len) + :element-type 'bit :initial-element fill))) + (do ((i 0 (1+ i))) + ((= i input-len) bvec) + (declare (index i) (optimize (sb-c:insert-array-bounds-checks 0))) + (let ((char (char bstring i))) + (setf (elt bvec i) + (case char + (#\0 0) + (#\1 1) + (t (simple-reader-error + stream "illegal element given for bit-vector: ~S" char))))))))) (defun sharp-A (stream ignore rank) (declare (ignore ignore)) @@ -157,8 +148,9 @@ (simple-reader-error stream "~S is not a defined structure type." (car body))) - (let ((default-constructor (dd-default-constructor - (layout-info (classoid-layout classoid))))) + (let ((default-constructor + (dd-default-constructor + (sb-kernel::wrapper-%info (classoid-wrapper classoid))))) (unless default-constructor (simple-reader-error stream @@ -283,7 +275,9 @@ `(let* ((old ,place) (new (recurse old))) (unless (eq old new) - (setf ,place new))))) + ,(if (eq (car place) '%instance-ref) + `(%instance-set ,@(cdr place) new) + `(setf ,place new)))))) (typecase tree (cons (process (car tree)) @@ -297,15 +291,15 @@ (instance ;; Don't refer to the DD-SLOTS unless there is reason to, ;; that is, unless some slot might be raw. - (if (/= +layout-all-tagged+ (layout-bitmap (%instance-layout tree))) - (let ((dd (layout-dd (%instance-layout tree)))) - (dolist (dsd (dd-slots dd)) - (when (eq (dsd-raw-type dsd) t) - (process (%instance-ref tree (dsd-index dsd)))))) + (if (sb-kernel::bitmap-all-taggedp (%instance-layout tree)) (do ((len (%instance-length tree)) (i sb-vm:instance-data-start (1+ i))) ((>= i len)) - (process (%instance-ref tree i))))) + (process (%instance-ref tree i))) + (let ((dd (wrapper-dd (%instance-wrapper tree)))) + (dolist (dsd (dd-slots dd)) + (when (eq (dsd-raw-type dsd) t) + (process (%instance-ref tree (dsd-index dsd)))))))) ;; ASSUMPTION: all funcallable instances have at least 1 slot ;; accessible via FUNCALLABLE-INSTANCE-INFO. ;; The only such objects with reader syntax are CLOS objects, diff -Nru sbcl-2.1.1/src/code/signal.lisp sbcl-2.1.11/src/code/signal.lisp --- sbcl-2.1.1/src/code/signal.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/signal.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -51,7 +51,7 @@ ;;; These 4 symbols are initialized by create_thread_struct() (defvar *interrupts-enabled*) (defvar *interrupt-pending*) -#+sb-thruption (defvar *thruption-pending*) +#+sb-safepoint (defvar *thruption-pending*) (defvar *allow-with-interrupts*) ;;; This is to support signal handlers that want to return to the @@ -65,13 +65,13 @@ ;;; would not cut it, as upon leaving WITHOUT-INTERRUPTS the pending ;;; handlers is run with stuff from the function in which this is ;;; still on the stack. -(defparameter *unblock-deferrables-on-enabling-interrupts-p* nil) +(defvar *unblock-deferrables-on-enabling-interrupts-p* nil) (eval-when (:compile-toplevel :load-toplevel :execute) (dolist (symbol '(*unblock-deferrables-on-enabling-interrupts-p* *interrupts-enabled* *interrupt-pending* - #+sb-thruption *thruption-pending* + #+sb-safepoint *thruption-pending* *allow-with-interrupts*)) ;; Force these to be always bound despite absence of a compile-time binding. ;; (Avoid accidentally installing a value into symbol->value in cold-load) @@ -154,7 +154,7 @@ ;; handled immediately upon exit from said ;; WITHOUT-INTERRUPTS, so it is as if nothing has happened. (when (or *interrupt-pending* - #+sb-thruption *thruption-pending*) + #+sb-safepoint *thruption-pending*) (receive-pending-interrupt))) (,without-interrupts-body))))) diff -Nru sbcl-2.1.1/src/code/simple-fun.lisp sbcl-2.1.11/src/code/simple-fun.lisp --- sbcl-2.1.1/src/code/simple-fun.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/simple-fun.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,8 +14,7 @@ ;;; Underlying SIMPLE-FUN (defun %fun-fun (function) (declare (function function)) - ;; It's too bad that TYPECASE isn't able to generate equivalent code. - (case (fun-subtype function) + (case (%fun-pointer-widetag function) (#.sb-vm:closure-widetag (%closure-fun function)) (#.sb-vm:funcallable-instance-widetag @@ -39,51 +38,54 @@ (logand (ash (function-header-word f) (- sb-vm:n-widetag-bits)) sb-vm:short-header-max-words)) -(macrolet ((%closure-index-set (closure index val) - ;; Use the identical convention as %CLOSURE-INDEX-REF for the index. - ;; There are no closure slot setters, and in fact SLOT-SET - ;; does not exist in a variant that takes a non-constant index. - `(setf (sap-ref-lispobj (int-sap (get-lisp-obj-address ,closure)) - (+ (ash sb-vm:closure-info-offset sb-vm:word-shift) - (ash ,index sb-vm:word-shift) - (- sb-vm:fun-pointer-lowtag))) - ,val)) - (closure-header-word (closure) - `(sap-ref-word (int-sap (get-lisp-obj-address ,closure)) - (- sb-vm:fun-pointer-lowtag))) - (new-closure (len) +(defmacro closure-len->nvalues (length) + `(- ,length (1- sb-vm:closure-info-offset))) + +;; Return T if and only if CLOSURE has extra values that are physically +;; in a padding slot of the object and not in the external hash-table. +(defun closure-has-extra-values-slot-p (closure) + (declare (closure closure)) + (and (logtest (function-header-word closure) closure-extra-data-indicator) + (evenp (get-closure-length closure)))) + +(macrolet ((new-closure (nvalues) + ;; argument is the number of INFO words #-(or x86 x86-64) - `(sb-vm::%alloc-closure ,len (%closure-fun closure)) + `(sb-vm::%alloc-closure ,nvalues (%closure-fun closure)) #+(or x86 x86-64) `(with-pinned-objects ((%closure-fun closure)) ;; %CLOSURE-CALLEE manifests as a fixnum which remains ;; valid across GC due to %CLOSURE-FUN being pinned ;; until after the new closure is made. - (sb-vm::%alloc-closure ,len (sb-vm::%closure-callee closure)))) - (copy-slots (extra-bit) - `(progn - (loop with sap = (int-sap (get-lisp-obj-address copy)) - for i from 0 below (1- payload-len) - for ofs from (- (ash 2 sb-vm:word-shift) sb-vm:fun-pointer-lowtag) - by sb-vm:n-word-bytes - do (setf (sap-ref-lispobj sap ofs) (%closure-index-ref closure i))) - (setf (closure-header-word copy) ; Update the header - ;; Closure copy lost its high header bits, so OR them in again. - (logior #+(and immobile-space 64-bit sb-thread) - (sap-int (sb-vm::current-thread-offset-sap - sb-vm::thread-function-layout-slot)) - #+(and immobile-space 64-bit (not sb-thread)) - (get-lisp-obj-address sb-vm:function-layout) - (function-header-word copy) - ,extra-bit))))) + (sb-vm::%alloc-closure ,nvalues (sb-vm::%closure-callee closure)))) + (copy-slots (has-extra-data) + `(do ((j 0 (1+ j))) + ((>= j nvalues) + (with-pinned-objects (copy) + (let ((sap (sap+ (int-sap (get-lisp-obj-address copy)) + (- sb-vm:fun-pointer-lowtag)))) + (declare (ignorable sap)) + ,@(when has-extra-data + `((setf (sap-ref-word sap 0) + (logior (function-header-word copy) + closure-extra-data-indicator)))) + #+immobile-space ; copy the layout + (setf (sap-ref-32 sap 4) ; ASSUMPTION: little-endian + (logior (get-lisp-obj-address + (wrapper-friend ,(find-layout 'function))))) + #+metaspace ; copy the CODE (not accessible by index-ref) + (setf (sap-ref-lispobj sap (ash sb-vm::closure-code-slot sb-vm:word-shift)) + (sb-vm::%closure-code closure))))) + (%closure-index-set copy j (%closure-index-ref closure j))))) ;; This is factored out because of a cutting-edge implementation ;; of tracing wrappers that I'm trying to finish. (defun copy-closure (closure) (declare (closure closure)) - (let* ((payload-len (get-closure-length (truly-the function closure))) - (copy (new-closure (1- payload-len)))) - (with-pinned-objects (copy) (copy-slots 0)) + (let* ((nvalues (closure-len->nvalues + (get-closure-length (truly-the function closure)))) + (copy (new-closure nvalues))) + (copy-slots nil) copy)) ;;; Assign CLOSURE a new name and/or docstring in VALUES, and return the @@ -96,17 +98,15 @@ ;;; then a copy of the closure with extra slots reduces to case (1). (defun set-closure-extra-values (closure permit-copy data) (declare (closure closure)) - (let ((payload-len (get-closure-length (truly-the function closure))) - (extendedp (logtest (function-header-word closure) - closure-extra-data-indicator))) - (when (and (not extendedp) permit-copy (oddp payload-len)) - ;; PAYLOAD-LEN includes the trampoline, so the number of slots we would - ;; pass to %ALLOC-CLOSURE is 1 less than that, were it not for - ;; the fact that we actually want to create 1 additional slot. - ;; So in effect, asking for PAYLOAD-LEN does exactly the right thing. - (let ((copy (new-closure payload-len))) + (let* ((len (get-closure-length (truly-the function closure))) + (nvalues (closure-len->nvalues len)) + (has-padding-slot (evenp len)) + (extendedp (logtest (function-header-word closure) + closure-extra-data-indicator))) + (when (and (not extendedp) (not has-padding-slot) permit-copy) + (let ((copy (new-closure (1+ nvalues)))) (with-pinned-objects (copy) - (copy-slots closure-extra-data-indicator) + (copy-slots t) ;; We copy only if there was no padding, which means that adding 1 slot ;; physically adds 2 slots. You might think that the added data go in the ;; first new slot, followed by padding. Nope! Take an example of a @@ -121,17 +121,20 @@ ;; CLOSURE-EXTRA-VALUES always reads 1 word past the stated payload size ;; regardless of whether the closure really captured the implied ;; number of closure values. - (%closure-index-set copy payload-len data) + (%closure-index-set copy (1+ nvalues) data) (return-from set-closure-extra-values copy)))) (unless (with-pinned-objects (closure) (unless extendedp ; Set the header bit - (setf (closure-header-word closure) + (setf (sap-ref-word (int-sap (get-lisp-obj-address closure)) + (- sb-vm:fun-pointer-lowtag)) (logior (function-header-word closure) closure-extra-data-indicator))) - (when (evenp payload-len) - (%closure-index-set closure (1- payload-len) data) + (when has-padding-slot + (%closure-index-set closure nvalues data) t)) - (setf (gethash closure **closure-extra-values**) data))) + (if (unbound-marker-p data) + (remhash closure **closure-extra-values**) + (setf (gethash closure **closure-extra-values**) data)))) closure)) (defun pack-closure-extra-values (name docstring) @@ -158,40 +161,21 @@ ;; an even-length payload takes the last slot for the name, ;; and an odd-length payload uses the global hashtable. (declare (closure closure)) - (let ((header-word (function-header-word closure))) - (if (not (logtest header-word closure-extra-data-indicator)) - (values unbound unbound) - (let* ((len (logand (ash header-word (- sb-vm:n-widetag-bits)) - sb-vm:short-header-max-words)) - (data - (if (oddp len) - ;; Boxed length odd implies total length even which implies - ;; no extra slot in which to store ancillary data. - (gethash closure **closure-extra-values** 0) - ;; GET-CLOSURE-LENGTH counts the 'fun' slot in the length, - ;; but %CLOSURE-INDEX-REF starts indexing from the value slots. - (%closure-index-ref closure (1- len))))) - ;; There can be a concurrency glitch, because the 'extended' flag is - ;; toggled to indicate that extra data are present before the data - ;; are written; so there's a window where NAME looks like 0. That could - ;; be fixed in the setter, or caught here, but it shouldn't matter. + (if (logtest (function-header-word closure) closure-extra-data-indicator) + (let* ((len (get-closure-length closure)) + ;; See examples in doc/internals-notes/closure + (data (if (evenp len) ; has padding slot + (%closure-index-ref closure (closure-len->nvalues len)) + ; No padding slot + (gethash closure **closure-extra-values** 0)))) (typecase data + ((eql 0) (values unbound unbound)) ((cons t (or string null (satisfies unbound-marker-p))) (values (car data) (cdr data))) ;; NIL represents an explicit docstring of NIL, not the name. ((or string null) (values unbound data)) - (t (values data unbound))))))) - -;; Return T if and only if CLOSURE has extra values that are physically -;; in the padding slot of the object and not in the external hash-table. -(defun closure-has-extra-values-slot-p (closure) - (declare (closure closure)) - (let ((header-word (function-header-word closure))) - (and (logtest header-word closure-extra-data-indicator) - ;; If the boxed payload length is even, adding the header makes it odd, - ;; so there's a padding slot for alignment to an even total word count. - ;; i.e. if the least-significant bit of the size field is 0, there's padding. - (not (logbitp sb-vm:n-widetag-bits header-word))))) + (t (values data unbound)))) + (values unbound unbound))) (defconstant +closure-name-index+ 0) (defconstant +closure-doc-index+ 1) @@ -206,7 +190,7 @@ ;;; (i.e., the third value returned from CL:FUNCTION-LAMBDA-EXPRESSION), ;;; or NIL if there's none (defun %fun-name (function) - (case (fun-subtype function) + (case (%fun-pointer-widetag function) (#.sb-vm:closure-widetag (let ((val (nth-value +closure-name-index+ (closure-extra-values function)))) (unless (unbound-marker-p val) @@ -226,7 +210,7 @@ (%simple-fun-name (%fun-fun function))) (defun (setf %fun-name) (new-value function) - (case (fun-subtype function) + (case (%fun-pointer-widetag function) (#.sb-vm:closure-widetag (set-closure-name (truly-the closure function) nil new-value)) (#.sb-vm:simple-fun-widetag @@ -310,7 +294,7 @@ ((not simple-vector) info)))) ;; For backward-compatibility we expand SFUNCTION -> FUNCTION. (if (and (listp internal-type) (eq (car internal-type) 'sfunction)) - (sb-ext:typexpand-1 internal-type) + (values (sb-ext:typexpand-1 internal-type)) internal-type))) (defun %simple-fun-xrefs (fun) @@ -319,14 +303,30 @@ ((cons t simple-vector) (cdr info)) (simple-vector info)))) -(defun %fun-type (function) +(defun %fun-ftype (function) (typecase function #+sb-fasteval ;; Obtain a list of the right shape, usually with T for each ;; arg type, but respecting local declarations if any. - (interpreted-function (sb-interpreter:%fun-type function)) + (interpreted-function (sb-interpreter:%fun-ftype function)) (t (%simple-fun-type (%fun-fun function))))) +(defun ftype-from-fdefn (name) + (declare (ignorable name)) + (let ((function (awhen (find-fdefn name) (fdefn-fun it)))) + (if (not function) + (specifier-type 'function) + ;; Never signal the PARSE-UNKNOWN-TYPE condition. + ;; This affects 2 regression tests, both very contrived: + ;; - in defstruct.impure ASSERT-ERROR (BUG127--FOO (MAKE-BUG127-E :FOO 3)) + ;; - in compiler.impure at :IDENTIFY-SUSPECT-VOPS + (let* ((ftype (%fun-ftype function)) + (context + (sb-kernel::make-type-context + ftype nil sb-kernel::+type-parse-signal-inhibit+))) + (declare (truly-dynamic-extent context)) + (values (sb-kernel::basic-parse-typespec ftype context)))))) + ;;; Return the lambda expression for SIMPLE-FUN if compiled to memory ;;; and rentention of forms was enabled via the EVAL-STORE-SOURCE-FORM policy ;;; (as is the default). @@ -352,10 +352,6 @@ (if (and form doc) (cons form doc) (or form doc)))) doc) -(defun %simple-fun-next (simple-fun) ; DO NOT USE IN NEW CODE - (%code-entry-point (fun-code-header simple-fun) - (1+ (%simple-fun-index simple-fun)))) - ;;; Return the number of bytes to subtract from the untagged address of SIMPLE-FUN ;;; to obtain the untagged address of its code component. ;;; See also CODE-FROM-FUNCTION. @@ -374,6 +370,14 @@ ;;;; CODE-COMPONENT +;;; software mark bits on pages of code require that all assignments to +;;; header slots go through the CODE-HEADER-SET vop, +;;; which is slightly different from the general soft card mark implementation +;;; for historical reasons. +(defun (setf %code-debug-info) (newval code) + (setf (code-header-ref code sb-vm:code-debug-info-slot) newval) + newval) + (defun %code-debug-info (code-obj) ;; Extract the unadulterated debug-info emitted by the compiler. The slot ;; value might be a cons of that and info stuffed in by the debugger. @@ -383,6 +387,10 @@ ;; return it unchanged in all other cases info))) +(defun (setf sb-vm::%code-fixups) (newval code) + (code-header-set code sb-vm::code-fixups-slot newval) + newval) + (declaim (inline code-obj-is-filler-p)) (defun code-obj-is-filler-p (code-obj) ;; See also HOLE-P in the allocator (same thing but using SAPs) @@ -465,6 +473,7 @@ (defun %code-entry-point (code-obj fun-index) (declare (type (unsigned-byte 16) fun-index)) + ;; FIXME: it should probably be an error to pass FUN-INDEX too large (when (< fun-index (code-n-entries code-obj)) (truly-the function (values (%primitive sb-c:compute-fun code-obj diff -Nru sbcl-2.1.1/src/code/sort.lisp sbcl-2.1.11/src/code/sort.lisp --- sbcl-2.1.1/src/code/sort.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/sort.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -325,14 +325,18 @@ (type (or null function) key)) (declare (explicit-check)) (declare (dynamic-extent pred key)) - (vector-merge-sort vector pred key svref)) + (if (<= (length vector) 1) ; avoid consing + vector + (vector-merge-sort vector pred key svref))) (defun stable-sort-vector (vector pred key) (declare (type function pred) (type (or null function) key)) (declare (explicit-check)) (declare (dynamic-extent pred key)) - (vector-merge-sort vector pred key aref)) + (if (<= (length vector) 1) ; avoid consing + vector + (vector-merge-sort vector pred key aref))) ;;;; merging diff -Nru sbcl-2.1.1/src/code/source-location.lisp sbcl-2.1.11/src/code/source-location.lisp --- sbcl-2.1.1/src/code/source-location.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/source-location.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -96,14 +96,27 @@ (%make-definition-source-location namestring tlf-number form-number))) (defun make-file-info-namestring (name file-info) - (let* ((untruename (file-info-untruename file-info)) - (dir (and untruename (pathname-directory untruename)))) + (let* ((pathname (file-info-pathname file-info)) + (dir (and pathname (pathname-directory pathname)))) (if (and dir (eq (first dir) :absolute)) - (namestring untruename) + (namestring pathname) (if name (namestring name) nil)))) +#+sb-source-locations +(progn + (define-source-transform source-location () + (make-definition-source-location)) + ;; We need a regular definition of SOURCE-LOCATION for calls processed + ;; during LOAD on a source file while *EVALUATOR-MODE* is :INTERPRET. + #-sb-xc-host + (defun source-location () + (make-definition-source-location))) + +#-sb-source-locations +(defun source-location () nil) + (in-package "SB-IMPL") (defvar *eval-source-context* nil) diff -Nru sbcl-2.1.1/src/code/sparc-vm.lisp sbcl-2.1.11/src/code/sparc-vm.lisp --- sbcl-2.1.1/src/code/sparc-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/sparc-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -15,6 +15,9 @@ "Returns a string describing the type of the local machine." "SPARC") +(defun return-machine-address (scp) + (+ (context-register scp lip-offset) 8)) + ;;;; "Sigcontext" access functions, cut & pasted from alpha-vm.lisp. ;;;; @@ -30,13 +33,15 @@ (* long) (context (* os-context-t)) (index int)) -#+nil (defun context-float-register (context index format) (declare (type (alien (* os-context-t)) context)) + (error "context-float-register not working yet? ~S" (list context index format)) + #+nil (coerce (deref (context-float-register-addr context index)) format)) -#+nil (defun %set-context-float-register (context index format new) (declare (type (alien (* os-context-t)) context)) + (error "%set-context-float-register not working yet? ~S" (list context index format new)) + #+nil (setf (deref (context-float-register-addr context index)) (coerce new format))) diff -Nru sbcl-2.1.1/src/code/specializable-array.lisp sbcl-2.1.11/src/code/specializable-array.lisp --- sbcl-2.1.1/src/code/specializable-array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/specializable-array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -59,14 +59,7 @@ (initial-contents nil contentsp) (initial-element 0) (retain-specialization-for-after-xc-core)) - ;; ECL fails to compile MAKE-ARRAY when keyword args are not literal keywords. e.g.: - ;; (DEFUN TRY (DIMS SELECT VAL) - ;; (MAKE-ARRAY DIMS (IF SELECT :INITIAL-CONTENTS :INITIAL-ELEMENT) VAL)) -> - ;; "The macro form (MAKE-ARRAY DIMS (IF SELECT :INITIAL-CONTENTS :INITIAL-ELEMENT) VAL) - ;; was not expanded successfully. - ;; Error detected: - ;; The key (IF SELECT :INITIAL-CONTENTS :INITIAL-ELEMENT) is not allowed" - #+host-quirks-ecl (declare (notinline cl:make-array)) + (declare (notinline cl:make-array)) (aver element-type) ;; Canonicalize diff -Nru sbcl-2.1.1/src/code/stream.lisp sbcl-2.1.11/src/code/stream.lisp --- sbcl-2.1.1/src/code/stream.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/stream.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -90,19 +90,6 @@ ;;; stream manipulation functions -(defstruct (broadcast-stream (:include ansi-stream - (out #'broadcast-out) - (bout #'broadcast-bout) - (sout #'broadcast-sout) - (misc #'broadcast-misc)) - (:constructor %make-broadcast-stream - (streams)) - (:copier nil) - (:predicate nil)) - ;; a list of all the streams we broadcast to - (streams () :type list :read-only t)) -(declaim (freeze-type broadcast-stream)) - (defun maybe-resolve-synonym-stream (stream) (labels ((recur (stream) (if (synonym-stream-p stream) @@ -137,7 +124,9 @@ (defmethod open-stream-p ((stream ansi-stream)) ;; CLHS 21.1.4 lets us not worry about synonym streams here. - (not (eq (ansi-stream-in stream) #'closed-flame))) + (let ((in (ansi-stream-in stream))) + (not (or (eq in (load-time-value #'closed-flame t)) + (eq in (load-time-value #'closed-flame-saved t)))))) (defmethod stream-element-type ((stream ansi-stream)) (call-ansi-stream-misc stream :element-type)) @@ -368,7 +357,7 @@ (eof) (index 0)) (declare (type (simple-array character (*)) buffer)) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (declare (index index)) (setf (schar res index) (truly-the character ch)) (incf index) @@ -403,8 +392,9 @@ (values (eof-or-lose stream eof-error-p eof-value) t) (values string eof))))) -;;; We proclaim them INLINE here, then proclaim them NOTINLINE later on, -;;; so, except in this file, they are not inline by default, but they can be. +;;; We proclaim them INLINE here, then proclaim them MAYBE-INLINE +;;; later on, so, except in this file, they are not inline by default, +;;; but they can be. (declaim (inline read-char unread-char read-byte)) (declaim (inline ansi-stream-read-char)) @@ -562,44 +552,25 @@ (declare (type ansi-stream stream) (type index numbytes start) (type (or (simple-array * (*)) system-area-pointer) buffer)) - (let* ((in-buffer (ansi-stream-in-buffer stream)) - (index (ansi-stream-in-index stream)) - (num-buffered (- +ansi-stream-in-buffer-length+ index))) - (declare (fixnum index num-buffered)) - (cond - ((not in-buffer) - (funcall (ansi-stream-n-bin stream) - stream - buffer - start - numbytes - eof-error-p)) - ((<= numbytes num-buffered) - #+nil - (let ((copy-function (typecase buffer - ((simple-array * (*)) #'ub8-bash-copy) - (system-area-pointer #'copy-ub8-to-system-area)))) - (funcall copy-function in-buffer index buffer start numbytes)) - (%byte-blt in-buffer index - buffer start (+ start numbytes)) - (setf (ansi-stream-in-index stream) (+ index numbytes)) - numbytes) - (t - (let ((end (+ start num-buffered))) - #+nil - (let ((copy-function (typecase buffer - ((simple-array * (*)) #'ub8-bash-copy) - (system-area-pointer #'copy-ub8-to-system-area)))) - (funcall copy-function in-buffer index buffer start num-buffered)) - (%byte-blt in-buffer index buffer start end) - (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) - (+ (funcall (ansi-stream-n-bin stream) - stream - buffer - end - (- numbytes num-buffered) - eof-error-p) - num-buffered)))))) + (let ((in-buffer (ansi-stream-in-buffer stream))) + (unless in-buffer + (return-from ansi-stream-read-n-bytes + (funcall (ansi-stream-n-bin stream) stream buffer start numbytes eof-error-p))) + (let* ((index (ansi-stream-in-index stream)) + (num-buffered (- +ansi-stream-in-buffer-length+ index))) + ;; These bytes are of course actual bytes, i.e. 8-bit octets + ;; and not variable-length bytes. + (cond ((<= numbytes num-buffered) + (%byte-blt in-buffer index buffer start (+ start numbytes)) + (setf (ansi-stream-in-index stream) (+ index numbytes)) + numbytes) + (t + (let ((end (+ start num-buffered))) + (%byte-blt in-buffer index buffer start end) + (setf (ansi-stream-in-index stream) +ansi-stream-in-buffer-length+) + (+ (funcall (ansi-stream-n-bin stream) stream buffer + end (- numbytes num-buffered) eof-error-p) + num-buffered))))))) ;;; the amount of space we leave at the start of the in-buffer for ;;; unreading @@ -797,7 +768,7 @@ integer) -(declaim (notinline read-char unread-char read-byte)) ; too big +(declaim (maybe-inline read-char unread-char read-byte)) ; too big ;;; This is called from ANSI-STREAM routines that encapsulate CLOS ;;; streams to handle the misc routines and dispatch to the @@ -1342,14 +1313,15 @@ ;;; of WITH-INPUT-FROM-STRING, and we lack a way to perform partial inline ;;; dx allocation of structures, this'll have to do. (defun %init-string-input-stream (stream string &optional (start 0) end) - (declare (string string)) - (setf (%instance-layout (truly-the instance stream)) + (declare (explicit-check string)) + (setf (%instance-wrapper (truly-the instance stream)) #.(find-layout 'string-input-stream)) (macrolet ((initforms () - `(setf - ,@(mapcan (lambda (dsd) - (list `(%instance-ref stream ,(dsd-index dsd)) - (case (dsd-name dsd) + `(progn + ,@(mapcar (lambda (dsd) + ;; good thing we have no raw slots in stream structures + `(%instance-set stream ,(dsd-index dsd) + ,(case (dsd-name dsd) ((index start) 'start) (limit 'end) (string 'simple-string) @@ -1368,31 +1340,25 @@ (t (setf (string-input-stream-index stream) (1+ index)) (char string index)))))) - (flet ((base-char-in (stream eof-error-p eof-value) - (declare (optimize (sb-c::verify-arg-count 0) - (sb-c::insert-array-bounds-checks 0))) - (char-in base-char)) - (character-in (stream eof-error-p eof-value) - (declare (optimize (sb-c::verify-arg-count 0) - (sb-c::insert-array-bounds-checks 0))) - (char-in character)) - (nil-in (stream eof-error-p eof-value) - (if (>= (string-input-stream-index stream) - (string-input-stream-limit stream)) - (eof-or-lose stream eof-error-p eof-value) - (error "Attempt to read from stream with NIL element type")))) - (let ((input-routine - (typecase string - #+sb-unicode (sb-kernel::character-string #'character-in) - (base-string #'base-char-in) - (t #'nil-in)))) - (with-array-data ((simple-string string :offset-var offset) - (start start) - (end end) - :check-fill-pointer t) - (initforms) - (values (truly-the string-input-stream stream) - offset)))))) + (flet ((base-char-in (stream eof-error-p eof-value) + (declare (optimize (sb-c::verify-arg-count 0) + (sb-c:insert-array-bounds-checks 0))) + (char-in base-char)) + (character-in (stream eof-error-p eof-value) + (declare (optimize (sb-c::verify-arg-count 0) + (sb-c:insert-array-bounds-checks 0))) + (char-in character))) + (let ((input-routine + (etypecase string + (base-string #'base-char-in) + (string #'character-in)))) + (with-array-data ((simple-string string :offset-var offset) + (start start) + (end end) + :check-fill-pointer t) + (initforms) + (values (truly-the string-input-stream stream) + offset)))))) ;;; It's debatable whether we should try to convert ;;; (let ((s (make-string-input-stream))) (declare (dynamic-extent s)) ...) @@ -1415,11 +1381,12 @@ (declare (optimize speed (sb-c::verify-arg-count 0))) (declare (string buffer) (ignorable wild-result-type)) ; if #-sb-unicode - (setf (%instance-layout (truly-the instance stream)) #.(find-layout 'string-output-stream)) + (setf (%instance-wrapper (truly-the instance stream)) #.(find-layout 'string-output-stream)) (macrolet ((initforms () - `(setf ,@(mapcan (lambda (dsd) - (list `(%instance-ref stream ,(dsd-index dsd)) - (case (dsd-name dsd) + `(progn + ,@(mapcar (lambda (dsd) + `(%instance-set stream ,(dsd-index dsd) + ,(case (dsd-name dsd) (sout '#'string-sout) ; global fun (misc '#'misc) ; local fun ((element-type unicode-p out sout-aux buffer) @@ -1433,7 +1400,7 @@ (buffer (truly-the (simple-array ,elt-type (*)) (string-output-stream-buffer stream))) (index (string-output-stream-index stream))) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (when (= pointer (length buffer)) ;; The usual doubling technique: the new buffer shall hold as many ;; characters as were already emplaced. @@ -1477,7 +1444,7 @@ ;; BASE-STRING, we needn't check anything. ;; Bounds check was already performed `(let ((s (truly-the simple-character-string src))) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (loop for i from start2 below end2 thereis (>= (char-code (aref s i)) base-char-code-limit))))) ;; The "wonderful" thing is you never know where type checks have already been done. @@ -1535,7 +1502,7 @@ nil)) (defun %make-character-string-ostream () (%init-string-output-stream (%allocate-string-ostream) - (make-array 31 :element-type 'character) ; 2w + 128b + (make-array 32 :element-type 'character) ; 2w + 128b nil)) (defun make-string-output-stream (&key (element-type 'character)) @@ -1834,7 +1801,7 @@ result)) (defun finite-base-string-ouch (stream character) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (let ((pointer (finite-base-string-output-stream-pointer stream)) (buffer (finite-base-string-output-stream-buffer stream))) (cond ((= pointer (length buffer)) @@ -1845,7 +1812,7 @@ (truly-the index (1+ pointer))))))) (defun finite-base-string-sout (stream string start end) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (let* ((pointer (finite-base-string-output-stream-pointer stream)) (buffer (finite-base-string-output-stream-buffer stream)) (length (- end start)) @@ -1913,12 +1880,12 @@ (unless (and (stringp string) (array-has-fill-pointer-p string)) (error "~S is not a string with a fill-pointer" string)) - (setf (%instance-layout (truly-the instance stream)) + (setf (%instance-wrapper (truly-the instance stream)) #.(find-layout 'fill-pointer-output-stream)) (macrolet ((initforms () - `(setf ,@(mapcan (lambda (dsd) - (list `(%instance-ref stream ,(dsd-index dsd)) - (case (dsd-name dsd) + `(progn ,@(mapcar (lambda (dsd) + `(%instance-set stream ,(dsd-index dsd) + ,(case (dsd-name dsd) (string 'string) (t (dsd-default dsd))))) (dd-slots @@ -2327,7 +2294,7 @@ :native (ansi-stream-read-sequence seq stream start end) :gray (stream-read-sequence stream seq start end))) -(declaim (inline read-sequence/read-function)) +(declaim (maybe-inline read-sequence/read-function)) (defun read-sequence/read-function (seq stream start %end stream-element-mode character-read-function binary-read-function) @@ -2395,7 +2362,6 @@ data offset-start offset-end)))) (t (read-generic-sequence (compute-read-function nil))))))) -(declaim (notinline read-sequence/read-function)) (defun ansi-stream-read-sequence (seq stream start %end) (declare (type sequence seq) @@ -2475,7 +2441,7 @@ (declare (type index i)) (funcall ,write-function ,stream (aref ,seq i)))))) -(declaim (inline write-sequence/write-function)) +(declaim (maybe-inline write-sequence/write-function)) (defun write-sequence/write-function (seq stream start %end stream-element-mode character-write-function @@ -2538,7 +2504,6 @@ (buffer-output stream data offset-start offset-end))))) (sequence (write-generic-sequence (compute-write-function nil))))))) -(declaim (notinline write-sequence/write-function)) ;;; This takes any kind of stream, not just ansi streams, because of recursion. ;;; It's basically just the non-keyword-accepting entry for WRITE-SEQUENCE. @@ -2631,4 +2596,131 @@ (concatenate 'string (subseq string 0 8) "...") string))))) -;;;; etc. + +;;;; initialization + +;;; the stream connected to the controlling terminal, or NIL if there is none +(defvar *tty*) + +;;; the stream connected to the standard input (file descriptor 0) +(defvar *stdin*) + +;;; the stream connected to the standard output (file descriptor 1) +(defvar *stdout*) + +;;; the stream connected to the standard error output (file descriptor 2) +(defvar *stderr*) + +;;; This is called when the cold load is first started up, and may also +;;; be called in an attempt to recover from nested errors. +(defun stream-cold-init-or-reset () + (stream-reinit) + (setf *terminal-io* (make-synonym-stream '*tty*)) + (setf *standard-output* (make-synonym-stream '*stdout*)) + (setf *standard-input* (make-synonym-stream '*stdin*)) + (setf *error-output* (make-synonym-stream '*stderr*)) + (setf *query-io* (make-synonym-stream '*terminal-io*)) + (setf *debug-io* *query-io*) + (setf *trace-output* *standard-output*) + (values)) + +(defun stream-deinit () + (setq *tty* nil *stdin* nil *stdout* nil *stderr* nil) + ;; Unbind to make sure we're not accidently dealing with it + ;; before we're ready (or after we think it's been deinitialized). + ;; This uses the internal %MAKUNBOUND because the CL: function would + ;; rightly complain that *AVAILABLE-BUFFERS* is proclaimed always bound. + (%makunbound '*available-buffers*)) + +(defvar *streams-closed-by-slad*) + +(defun restore-fd-streams () + (loop for (stream in bin n-bin out bout sout misc) in *streams-closed-by-slad* + do + (setf (ansi-stream-in stream) in) + (setf (ansi-stream-bin stream) bin) + (setf (ansi-stream-n-bin stream) n-bin) + (setf (ansi-stream-out stream) out) + (setf (ansi-stream-bout stream) bout) + (setf (ansi-stream-sout stream) sout) + (setf (ansi-stream-misc stream) misc))) + +(defun stdstream-external-format (fd) + #-win32 (declare (ignore fd)) + (let* ((keyword (cond #+(and win32 sb-unicode) + ((sb-win32::console-handle-p fd) + :ucs-2) + (t + (default-external-format)))) + (ef (get-external-format keyword)) + (replacement (ef-default-replacement-character ef))) + `(,keyword :replacement ,replacement))) + +;;; This is called whenever a saved core is restarted. +(defun stream-reinit (&optional init-buffers-p) + (when init-buffers-p + ;; Use the internal %BOUNDP for similar reason to that cited above- + ;; BOUNDP on a known global transforms to the constant T. + (aver (not (%boundp '*available-buffers*))) + (setf *available-buffers* nil)) + (%with-output-to-string (*error-output*) + (multiple-value-bind (in out err) + #-win32 (values 0 1 2) + #+win32 (sb-win32::get-std-handles) + (labels (#+win32 + (nul-stream (name inputp outputp) + (let ((nul-handle + (cond + ((and inputp outputp) + (sb-win32:unixlike-open "NUL" sb-unix:o_rdwr)) + (inputp + (sb-win32:unixlike-open "NUL" sb-unix:o_rdonly)) + (outputp + (sb-win32:unixlike-open "NUL" sb-unix:o_wronly)) + (t + ;; Not quite sure what to do in this case. + nil)))) + (make-fd-stream + nul-handle + :name name + :input inputp + :output outputp + :buffering :line + :element-type :default + :serve-events inputp + :auto-close t + :external-format (stdstream-external-format nul-handle)))) + (stdio-stream (handle name inputp outputp) + (cond + #+win32 + ((null handle) + ;; If no actual handle was present, create a stream to NUL + (nul-stream name inputp outputp)) + (t + (make-fd-stream + handle + :name name + :input inputp + :output outputp + :buffering :line + :element-type :default + :serve-events inputp + :external-format (stdstream-external-format handle)))))) + (setf *stdin* (stdio-stream in "standard input" t nil) + *stdout* (stdio-stream out "standard output" nil t) + *stderr* (stdio-stream err "standard error" nil t)))) + #+win32 + (setf *tty* (make-two-way-stream *stdin* *stdout*)) + #-win32 + (let ((tty (sb-unix:unix-open "/dev/tty" sb-unix:o_rdwr #o666))) + (setf *tty* + (if tty + (make-fd-stream tty :name "the terminal" + :input t :output t :buffering :line + :external-format (stdstream-external-format tty) + :serve-events t + :auto-close t) + (make-two-way-stream *stdin* *stdout*)))) + (princ (get-output-stream-string *error-output*) *stderr*)) + (values)) + diff -Nru sbcl-2.1.1/src/code/string.lisp sbcl-2.1.11/src/code/string.lisp --- sbcl-2.1.1/src/code/string.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/string.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -143,7 +143,7 @@ `(return-from string=* (let ((string1 (truly-the (simple-array ,type1 1) string1)) (string2 (truly-the (simple-array ,type2 1) string2))) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (do ((index1 start1 (1+ index1)) (index2 start2 (1+ index2))) ((>= index1 end1) t) @@ -435,26 +435,48 @@ (defun two-arg-string-not-greaterp (string1 string2) (string-not-greaterp* string1 string2 0 nil 0 nil)) -(defun make-string (count &key - (element-type 'character) - ((:initial-element fill-char))) +(defun make-string (count &key (element-type 'character) + (initial-element nil iep)) "Given a character count and an optional fill character, makes and returns a new string COUNT long filled with the fill character." (declare (index count)) (declare (explicit-check)) - ;; FIXME: while this is a correct implementation relying on an IR1 transform, - ;; it would be better if in the following example (assuming NOTINLINE): - ;; (MAKE-STRING 1000 :ELEMENT-TYPE 'BIT :INITIAL-element #\a) - ;; we could report that "BIT is not a subtype of CHARACTER" - ;; instead of "#\a is not of type BIT". Additionally, in this case: - ;; (MAKE-STRING 200000000 :ELEMENT-TYPE 'WORD :INITIAL-ELEMENT #\a) - ;; the error reported is heap exhaustion rather than type mismatch. - (if fill-char - (make-string count :element-type element-type - :initial-element (the character fill-char)) - (make-string count :element-type element-type))) + (cond ((eq element-type 'character) + (let ((c (if iep (the character initial-element))) + (s (make-string count :element-type 'character))) + (when c (sb-vm::unpoison s) (fill s c)) + s)) + ((or (eq element-type 'base-char) + (eq element-type 'standard-char) + ;; What's the "most specialized" thing possible that's still a string? + ;; Well clearly it's a string whose elements have the smallest domain. + ;; So that would be 8 bits per character, not 32 bits per character. + (eq element-type nil)) + (let ((c (if iep (the base-char initial-element))) + (s (make-string count :element-type 'base-char))) + (when c (sb-vm::unpoison s) (fill s c)) + s)) + (t + (multiple-value-bind (widetag n-bits-shift) + (sb-vm::%vector-widetag-and-n-bits-shift element-type) + (unless (or #+sb-unicode (= widetag sb-vm:simple-character-string-widetag) + (= widetag sb-vm:simple-base-string-widetag)) + (error "~S is not a valid :ELEMENT-TYPE for MAKE-STRING" element-type)) + ;; If you give a ridiculous type such as (member #\EN_SPACE) as your + ;; :ELEMENT-TYPE, then you get what you deserve - slow type checking. + (when (and iep (not (typep initial-element element-type))) + (error 'simple-type-error + :datum initial-element + :expected-type element-type + :format-control "~S is not a ~S" + :format-arguments (list initial-element element-type))) + (let ((string + (sb-vm::allocate-vector-with-widetag + #+ubsan nil widetag count n-bits-shift))) + (when initial-element (fill string initial-element)) + string))))) -(declaim (inline nstring-upcase)) +(declaim (maybe-inline nstring-upcase)) (defun nstring-upcase (string &key (start 0) end) (declare (explicit-check)) (if (typep string '(array nil (*))) @@ -467,27 +489,24 @@ string)) (with-one-string (string start end) (do ((index start (1+ index)) - (cases **character-cases**) - (case-pages **character-case-pages**)) + (cases +character-cases+)) ((>= index end)) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (let ((char (schar string index))) (with-case-info (char case-index cases - :cases cases - :case-pages case-pages) + :cases cases) (let ((code (aref cases (1+ case-index)))) (unless (zerop code) (setf (schar string index) (code-char (truly-the char-code code))))))))) string))) -(declaim (notinline nstring-upcase)) (defun string-upcase (string &key (start 0) end) (declare (explicit-check) (inline nstring-upcase)) (nstring-upcase (copy-seq (%string string)) :start start :end end)) -(declaim (inline nstring-downcase)) +(declaim (maybe-inline nstring-downcase)) (defun nstring-downcase (string &key (start 0) end) (declare (explicit-check)) (if (typep string '(array nil (*))) @@ -500,23 +519,20 @@ string)) (with-one-string (string start end) (do ((index start (1+ index)) - (cases **character-cases**) - (case-pages **character-case-pages**)) + (cases +character-cases+)) ((>= index end)) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (let ((char (schar (truly-the (or simple-base-string simple-character-string) string) index))) (with-case-info (char case-index cases - :cases cases - :case-pages case-pages) + :cases cases) (let ((code (aref cases case-index))) (unless (zerop code) (setf (schar string index) (code-char (truly-the char-code code))))))))) string))) -(declaim (notinline nstring-downcase)) (defun string-downcase (string &key (start 0) end) (declare (explicit-check) @@ -604,9 +620,14 @@ ;; "Always" means that regardless of whether the user want ;; coalescing of strings used as literals in code compiled to memory, ;; the string is shareable. - ;; #b01_ ; symbol name, literal compiled to fasl, some other stuff - ;; #b10_ ; literal compiled to core - (set-header-data (the (simple-array * 1) vector) - (if always-shareable - sb-vm:+vector-shareable+ - sb-vm:+vector-shareable-nonstd+))) + (when (eq (heap-allocated-p vector) :dynamic) + (logior-array-flags (the (simple-array * 1) vector) + (if always-shareable + sb-vm:+vector-shareable+ + sb-vm:+vector-shareable-nonstd+))) + vector) + +(clear-info :function :inlining-data 'nstring-upcase) +(clear-info :function :inlinep 'nstring-upcase) +(clear-info :function :inlining-data 'nstring-downcase) +(clear-info :function :inlinep 'nstring-downcase) diff -Nru sbcl-2.1.1/src/code/stubs.lisp sbcl-2.1.11/src/code/stubs.lisp --- sbcl-2.1.1/src/code/stubs.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/stubs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,6 +13,37 @@ (in-package "SB-IMPL") +(defun (cas symbol-value) (old new symbol) + (cas (symbol-value symbol) old new)) +(defun (cas svref) (old new vector index) + (cas (svref vector index) old new)) +#+(or ppc64 x86-64) +(macrolet ((def (name) + `(defun (cas ,name) (old new sap index) + (funcall #'(cas ,name) old new sap index)))) + (def sb-sys:sap-ref-8) + (def sb-sys:sap-ref-16) + (def sb-sys:sap-ref-32) + (def sb-sys:sap-ref-64) + (def sb-sys:signed-sap-ref-64) + (def sb-sys:sap-ref-sap) + (def sb-sys:sap-ref-lispobj)) + +(macrolet ((def (name &rest args) + `(defun ,name ,args + (,name ,@args)))) + (def word-logical-not x) + (def word-logical-and x y) + (def word-logical-or x y) + (def word-logical-xor x y) + (def word-logical-nor x y) + (def word-logical-eqv x y) + (def word-logical-nand x y) + (def word-logical-andc1 x y) + (def word-logical-andc2 x y) + (def word-logical-orc1 x y) + (def word-logical-orc2 x y)) + (macrolet ((def (name &optional (args '(x))) `(defun ,name ,args (,@(if (listp name) `(funcall #',name) `(,name)) ,@args))) @@ -29,7 +60,8 @@ (def sap-int) (def int-sap) (macrolet ((def-accessor (name) - `(progn (def ,(symbolicate "%SET-" name) (sap offset value)) + ;; the low-level %SET functions should not need stubs + `(progn (def (setf ,name) (value sap offset)) (def ,name (sap offset))))) (def-accessor sap-ref-8) (def-accessor sap-ref-16) @@ -46,6 +78,8 @@ (def-accessor sap-ref-single) (def-accessor sap-ref-double)) (def %byte-blt (src src-start dst dst-start dst-end)) + (def shift-towards-start (number count)) + (def shift-towards-end (number count)) (def get-header-data) (def set-header-data (x val)) (def widetag-of) @@ -58,9 +92,7 @@ #-(or x86 x86-64) (def dynamic-space-free-pointer ()) (def control-stack-pointer-sap ()) (def sb-c:safe-fdefn-fun) - (def fun-subtype) - (def simple-fun-p) - (def closurep) + (def %fun-pointer-widetag) (def %closure-fun) (def %closure-index-ref (closure index)) (def fdefn-name) @@ -70,7 +102,6 @@ (def make-array-header (type rank)) (def code-instructions) #-untagged-fdefns (def code-header-ref (code-obj index)) - (def code-header-set (code-obj index new)) (def %vector-raw-bits (object offset)) (def %set-vector-raw-bits (object offset value)) (def single-float-bits) @@ -81,26 +112,28 @@ (def value-cell-ref) (def %caller-frame ()) (def %caller-pc ()) - #+(or x86 x86-64) (def sb-vm::%code-fixups) + (def sb-vm::%code-fixups) #+x86-64 (def pointerp) ;; instances (def %make-instance) ; Allocate a new instance with X data slots. (def %instance-length) ; Given an instance, return its length. (def %instance-layout) + (def %instance-wrapper) (def %set-instance-layout (instance new-value)) ; (def %instance-ref (instance index)) ; defined in 'target-defstruct' (def %instance-set (instance index new-value)) ;; funcallable instances (def %make-funcallable-instance) (def %fun-layout) - (def %set-funcallable-instance-layout (fin new-value)) + (def %fun-wrapper) + (def %set-fun-layout (fin new-value)) (def %funcallable-instance-fun) (def (setf %funcallable-instance-fun) (fin new-value)) (def %funcallable-instance-info (fin i)) - (def %set-funcallable-instance-info (fin i new-value)) - #+(and compact-instance-header x86-64) (def layout-of) - #+64-bit (def layout-depthoid) + #+compact-instance-header (progn (def wrapper-of) + (def %instanceoid-layout)) + ;; lists (def %rplaca (x val)) (def %rplacd (x val)) @@ -114,29 +147,26 @@ (%make-simd-pack-single (x y z w)) (%make-simd-pack-double (low high)) (%make-simd-pack-ub64 (low high)) - (%simd-pack-tag) - (%simd-pack-low) - (%simd-pack-high)) + (%simd-pack-tag)) #+sb-simd-pack-256 (def* (%make-simd-pack-256 (tag p0 p1 p2 p3)) (%make-simd-pack-256-single (a b c d e f g h)) (%make-simd-pack-256-double (a b c d)) (%make-simd-pack-256-ub64 (a b c d)) - (%simd-pack-256-tag) - (%simd-pack-256-0) - (%simd-pack-256-1) - (%simd-pack-256-2) - (%simd-pack-256-3)) + (%simd-pack-256-tag)) #+sb-thread (def sb-vm::current-thread-offset-sap) (def current-sp ()) (def current-fp ()) (def stack-ref (s n)) - (def %set-stack-ref (s n value)) (def fun-code-header) (def symbol-hash) (def sb-vm::symbol-extra) #+sb-thread (def symbol-tls-index) - #.(if (fboundp 'symbol-info-vector) (values) '(def symbol-info-vector)) + (def symbol-%info) ; primitive reader always needs a stub + (def (setf symbol-%info) (info symbol)) ; as does primitive writer + ;; but the "wrapped" reader might not need a stub. + ;; If it's already a proper function, then it doesn't. + #.(if (fboundp 'symbol-dbinfo) (values) '(def symbol-dbinfo)) #-(or x86 x86-64) (def lra-code-header) (def %make-lisp-obj) (def get-lisp-obj-address) @@ -145,6 +175,24 @@ #+x86-64 (def single-float-sign)) +#+sb-simd-pack +(macrolet ((def (name) + `(defun ,name (pack) + (sb-vm::simd-pack-dispatch pack + (,name pack))))) + (def %simd-pack-low) + (def %simd-pack-high)) + +#+sb-simd-pack-256 +(macrolet ((def (name) + `(defun ,name (pack) + (sb-vm::simd-pack-256-dispatch pack + (,name pack))))) + (def %simd-pack-256-0) + (def %simd-pack-256-1) + (def %simd-pack-256-2) + (def %simd-pack-256-3)) + (defun spin-loop-hint () "Hints the processor that the current thread is spin-looping." (spin-loop-hint)) @@ -152,11 +200,11 @@ ;;; The stub for sb-c::%structure-is-a should really use layout-id in the same way ;;; that the vop does, however, because the all 64-bit architectures other than ;;; x86-64 need to use with-pinned-objects to extract a layout-id, it is cheaper not to. -;;; I shouid add a vop for uint32 access to raw slots. +;;; I should add a vop for uint32 access to raw slots. (defun sb-c::%structure-is-a (object-layout test-layout) (or (eq object-layout test-layout) - (let ((depthoid (layout-depthoid test-layout)) - (inherits (layout-inherits object-layout))) + (let ((depthoid (wrapper-depthoid test-layout)) + (inherits (wrapper-inherits object-layout))) (and (> (length inherits) depthoid) (eq (svref inherits depthoid) test-layout))))) diff -Nru sbcl-2.1.1/src/code/symbol.lisp sbcl-2.1.11/src/code/symbol.lisp --- sbcl-2.1.1/src/code/symbol.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/symbol.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -135,6 +135,19 @@ (let ((fdefn (find-or-create-fdefn symbol))) (setf (fdefn-fun fdefn) new-value)))) +;;; Incredibly bogus kludge: the :CAS-TRANS option in objdef makes no indication +;;; that you can not use it on certain platforms, so then you do try to use it, +;;; and you silently get no automatic IR2 conversion. The workaround in src/code/cas +;;; is unnecessary imho - why are we comparing the old value? +;;; To catch programming errors that occur only for non-threads apparently? +;;; The flaw is that it's dissociated from objdef, which ought to you give you +;;; the stub automatically somehow. +;;; Furthermore it's annoying that you can't name the CAS function (CAS fn). +#-compare-and-swap-vops +(defun cas-symbol-%info (symbol old new) + (setf (symbol-%info symbol) new) + old) + ;;; Accessors for the dual-purpose info/plist slot ;; A symbol's INFO slot is always in one of three states: @@ -149,14 +162,6 @@ ;; State 2 transitions to state 3 via ({SETF|CAS} SYMBOL-PLIST). ;; There are *no* other permissible state transitions. -(defun symbol-info (symbol) - (symbol-info symbol)) - -;; An "interpreter stub" for an operation that is only implemented for -;; the benefit of platforms without compare-and-swap-vops. -(defun (setf symbol-info) (new-info symbol) - (setf (symbol-info symbol) new-info)) - ;; Atomically update SYMBOL's info/plist slot to contain a new info vector. ;; The vector is computed by calling UPDATE-FN on the old vector, ;; repeatedly as necessary, until no conflict happens with other updaters. @@ -164,25 +169,25 @@ (defun update-symbol-info (symbol update-fn) (declare (symbol symbol) (type (function (t) t) update-fn)) - (prog ((info-holder (symbol-info symbol)) - (current-vect)) + (prog ((info-holder (symbol-%info symbol)) + (current-info)) ; a PACKED-INFO or NIL outer-restart - ;; Do not use SYMBOL-INFO-VECTOR - this must not perform a slot read again. - (setq current-vect (if (listp info-holder) (cdr info-holder) info-holder)) + ;; This _must_ _not_ perform another read of the INFO slot here. + (setq current-info (if (listp info-holder) (cdr info-holder) info-holder)) inner-restart - (let ((new-vect (funcall update-fn (or current-vect +nil-packed-infos+)))) - (unless (simple-vector-p new-vect) - (aver (null new-vect)) + (let ((new-info (funcall update-fn (or current-info +nil-packed-infos+)))) + (unless (%instancep new-info) + (aver (null new-info)) (return)) ; nothing to do (if (consp info-holder) ; State 3: exchange the CDR - (let ((old (%compare-and-swap-cdr info-holder current-vect new-vect))) - (when (eq old current-vect) (return t)) ; win - (setq current-vect old) ; Don't touch holder- it's still a cons + (let ((old (cas (cdr info-holder) current-info new-info))) + (when (eq old current-info) (return t)) ; win + (setq current-info old) ; Don't touch holder- it's still a cons (go inner-restart))) - ;; State 1 or 2: info-holder is NIL or a vector. - ;; Exchange the contents of the info slot. Type-inference derives - ;; SIMPLE-VECTOR-P on the args to CAS, so no extra checking. - (let ((old (%compare-and-swap-symbol-info symbol info-holder new-vect))) + ;; State 1 or 2: info-holder is NIL or a PACKED-INFO. + ;; Exchange the contents of the info slot. Type-inference should have + ;; derived that NEW-INFO satisfies the slot type restriction (I hope). + (let ((old (cas-symbol-%info symbol info-holder new-info))) (when (eq old info-holder) (return t)) ; win ;; Check whether we're in state 2 or 3 now. ;; Impossible to be in state 1: nobody ever puts NIL in the slot. @@ -190,38 +195,25 @@ (setq info-holder old) (go outer-restart))))) -(eval-when (:compile-toplevel) - ;; If we're in state 1 or state 3, we can take (CAR (SYMBOL-INFO S)) - ;; to get the property list. If we're in state 2, this same access - ;; gets the fixnum which is the VECTOR-LENGTH of the info vector. - ;; So all we have to do is turn any fixnum to NIL, and we have a plist. - ;; Ensure that this pun stays working. - #-ppc64 ; ppc64 has unevenly spaced lowtags - (assert (= (- (* sb-vm:n-word-bytes sb-vm:cons-car-slot) - sb-vm:list-pointer-lowtag) - (- (* sb-vm:n-word-bytes sb-vm:vector-length-slot) - sb-vm:other-pointer-lowtag)))) - (defun symbol-plist (symbol) "Return SYMBOL's property list." - (if (sb-c::vop-existsp :translate cl:symbol-plist) - (symbol-plist symbol) - (let ((list (car (truly-the list (symbol-info symbol))))) ; a harmless lie - ;; Just ensure the result is not a fixnum, and we're done. - (if (fixnump list) nil list)))) + (let ((list (symbol-%info symbol))) + ;; See the comments above UPDATE-SYMBOL-INFO for a + ;; reminder as to why this logic is right. + (if (%instancep list) nil (car list)))) (declaim (ftype (sfunction (symbol t) cons) %ensure-plist-holder) (inline %ensure-plist-holder)) ;; When a plist update (setf or cas) is first performed on a symbol, ;; a one-time allocation of an extra cons is done which creates two -;; "slots" from one: a slot for the info-vector and a slot for the plist. +;; "slots" from one: a slot for the PACKED-INFO and a slot for the plist. ;; This avoids complications in the implementation of the user-facing ;; (CAS SYMBOL-PLIST) function, which should not have to be aware of ;; competition from globaldb mutators even if no other threads attempt ;; to manipulate the plist per se. -;; Given a SYMBOL and its current INFO of type (OR LIST SIMPLE-VECTOR) +;; Given a SYMBOL and its current INFO of type (OR LIST INSTANCE) ;; ensure that SYMBOL's current info is a cons, and return that. ;; If racing with multiple threads, at most one thread will install the cons. (defun %ensure-plist-holder (symbol info) @@ -233,56 +225,55 @@ ;; The pointer from the new cons to the old info must be persisted ;; to memory before the symbol's info slot points to the cons. ;; [x86oid doesn't need the barrier, others might] - (sb-thread:barrier (:write) - (setq newcell (cons nil info))) - (loop (let ((old (%compare-and-swap-symbol-info symbol info newcell))) + (setq newcell (cons nil info)) + (sb-thread:barrier (:write)) ; oh such ghastly syntax + (loop (let ((old (cas-symbol-%info symbol info newcell))) (cond ((eq old info) (return newcell)) ; win ((consp old) (return old))) ; somebody else made a cons! (setq info old) - (sb-thread:barrier (:write) ; Retry using same newcell - (rplacd newcell info))))))) + (rplacd newcell info) + (sb-thread:barrier (:write))))))) ; Retry using same newcell -(declaim (inline %compare-and-swap-symbol-plist - %set-symbol-plist)) +(declaim (inline (cas symbol-plist) (setf symbol-plist))) -(defun %compare-and-swap-symbol-plist (symbol old new) - ;; This is the entry point into which (CAS SYMBOL-PLIST) is transformed. +(defun (cas symbol-plist) (old new symbol) ;; If SYMBOL's info cell is a cons, we can do (CAS CAR). Otherwise punt. (declare (symbol symbol) (list old new)) - (let ((cell (symbol-info symbol))) + (let ((cell (symbol-%info symbol))) (if (consp cell) (%compare-and-swap-car cell old new) - (%%compare-and-swap-symbol-plist symbol old new)))) + (%cas-symbol-plist old new symbol)))) -(defun %%compare-and-swap-symbol-plist (symbol old new) +(defun %cas-symbol-plist (old new symbol) ;; This is just the second half of a partially-inline function, to avoid ;; code bloat in the exceptional case. Type assertions should have been ;; done - or not, per policy - by the caller of %COMPARE-AND-SWAP-SYMBOL-PLIST ;; so now use TRULY-THE to avoid further type checking. (%compare-and-swap-car (%ensure-plist-holder (truly-the symbol symbol) - (symbol-info symbol)) + (symbol-%info symbol)) old new)) -(defun %set-symbol-plist (symbol new-value) - ;; This is the entry point into which (SETF SYMBOL-PLIST) is transformed. +(defun (setf symbol-plist) (new-value symbol) ;; If SYMBOL's info cell is a cons, we can do (SETF CAR). Otherwise punt. (declare (symbol symbol) (list new-value)) - (let ((cell (symbol-info symbol))) + (let ((cell (symbol-%info symbol))) (if (consp cell) (setf (car cell) new-value) - (%%set-symbol-plist symbol new-value)))) + (%set-symbol-plist symbol new-value)))) -(defun %%set-symbol-plist (symbol new-value) - ;; Same considerations as for %%COMPARE-AND-SWAP-SYMBOL-PLIST, +(defun %set-symbol-plist (symbol new-value) + ;; Same considerations as for %CAS-SYMBOL-PLIST, ;; with a slight efficiency hack: if the symbol has no plist holder cell ;; and the NEW-VALUE is NIL, try to avoid creating a holder cell. ;; Yet we must write something, because omitting a memory operation ;; could have a subtle effect in the presence of multi-threading. - (let ((info (symbol-info (truly-the symbol symbol)))) + (let ((info (symbol-%info (truly-the symbol symbol)))) (when (and (not new-value) (atom info)) ; try to treat this as a no-op - (let ((old (%compare-and-swap-symbol-info symbol info info))) + ;; INFO is either an INSTANCE (a PACKED-INFO) or NIL. + ;; Write the same thing back, to say we set the plist to NIL. + (let ((old (cas-symbol-%info symbol info info))) (if (eq old info) ; good enough - (return-from %%set-symbol-plist new-value) ; = nil + (return-from %set-symbol-plist new-value) ; = nil (setq info old)))) (setf (car (%ensure-plist-holder symbol info)) new-value))) @@ -329,7 +320,7 @@ #+immobile-space (defun %make-symbol (kind name) (declare (ignorable kind) (type simple-string name)) - (set-header-data name sb-vm:+vector-shareable+) ; Set "logically read-only" bit + (logior-array-flags name sb-vm:+vector-shareable+) ; Set "logically read-only" bit (if #-immobile-symbols (or (eql kind 1) ; keyword (and (eql kind 2) ; random interned symbol diff -Nru sbcl-2.1.1/src/code/sysmacs.lisp sbcl-2.1.11/src/code/sysmacs.lisp --- sbcl-2.1.1/src/code/sysmacs.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/sysmacs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -29,7 +29,7 @@ ;;; This one is initialized by the runtime, at thread creation. On ;;; non-x86oid gencgc targets, this is a per-thread list of objects ;;; which must not be moved during GC. It is frobbed by the code for -;;; with-pinned-objects in src/compiler/target/macros.lisp. +;;; with-pinned-objects in src/compiler/{arch}/macros.lisp. #+(and gencgc (not (or x86 x86-64))) (defvar sb-vm::*pinned-objects*) @@ -86,7 +86,7 @@ ;;; ;;; FIXME: Shouldn't these be functions instead of macros? (defmacro in-stream-from-designator (stream) - (let ((svar (gensym))) + (let ((svar (sb-xc:gensym))) `(let ((,svar ,stream)) (cond ((null ,svar) *standard-input*) ((eq ,svar t) *terminal-io*) @@ -111,7 +111,7 @@ (t (return x)))))) |# (defmacro out-stream-from-designator (stream) - (let ((svar (gensym))) + (let ((svar (sb-xc:gensym))) `(let ((,svar ,stream)) (cond ((null ,svar) *standard-output*) ((eq ,svar t) *terminal-io*) diff -Nru sbcl-2.1.1/src/code/target-alieneval.lisp sbcl-2.1.11/src/code/target-alieneval.lisp --- sbcl-2.1.1/src/code/target-alieneval.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-alieneval.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -314,7 +314,7 @@ ;;; an invocation of INVOKE-WITH-SAVED-FP, which should be inlined. #+c-stack-is-control-stack (defun invoke-with-saved-fp (fn) - (declare #-sb-xc-host (muffle-conditions compiler-note) + (declare (muffle-conditions compiler-note) (optimize (speed 3))) ;; No need to link to the previous value, it can be fetched from the binding stack. (let ((*saved-fp* (sb-c::current-fp-fixnum))) @@ -767,8 +767,13 @@ passed, with the object being initialized from the supplied argument and the return value being determined by accessing the object on return." - (multiple-value-bind (lisp-name alien-name) - (pick-lisp-and-alien-names name) + (binding* (((lisp-name alien-name) (pick-lisp-and-alien-names name)) + ;; The local name is uninterned so that we don't preclude + ;; (defconstant kill 9) + ;; (define-alien-routine "kill" int (pid int) (sig int)) + ;; which, if we didn't hide the local name, would get: + ;; "Attempt to bind a constant variable with SYMBOL-MACROLET: KILL" + (local-name (copy-symbol lisp-name))) (collect ((docs) (lisp-args) (lisp-arg-types) (lisp-result-types (cond ((eql result-type 'void) @@ -782,38 +787,41 @@ (arg-types) (alien-vars) (alien-args) (results)) (dolist (arg args) - (if (stringp arg) - (docs arg) - (destructuring-bind (name type &optional (style :in)) arg - (unless (member style '(:in :copy :out :in-out)) - (error "bogus argument style ~S in ~S" style arg)) - (when (and (member style '(:out :in-out)) - (typep (parse-alien-type type lexenv) - 'alien-pointer-type)) - (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" - type)) - (let (arg-type) - (cond ((eq style :in) - (setq arg-type type) - (alien-args name)) - (t - (setq arg-type `(* ,type)) - (if (eq style :out) - (alien-vars `(,name ,type)) - (alien-vars `(,name ,type ,name))) - (alien-args `(addr ,name)))) - (arg-types arg-type) - (unless (eq style :out) - (lisp-args name) - (lisp-arg-types t - ;; FIXME: It should be something - ;; like `(ALIEN ,ARG-TYPE), except - ;; for we also accept SAPs where - ;; pointers are required. - ))) - (when (or (eq style :out) (eq style :in-out)) - (results name) - (lisp-result-types `(alien ,type)))))) + (cond ((stringp arg) + (docs arg)) + ((eq arg '&optional) + (arg-types arg)) + (t + (destructuring-bind (name type &optional (style :in)) arg + (unless (member style '(:in :copy :out :in-out)) + (error "bogus argument style ~S in ~S" style arg)) + (when (and (member style '(:out :in-out)) + (typep (parse-alien-type type lexenv) + 'alien-pointer-type)) + (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" + type)) + (let (arg-type) + (cond ((eq style :in) + (setq arg-type type) + (alien-args name)) + (t + (setq arg-type `(* ,type)) + (if (eq style :out) + (alien-vars `(,name ,type)) + (alien-vars `(,name ,type ,name))) + (alien-args `(addr ,name)))) + (arg-types arg-type) + (unless (eq style :out) + (lisp-args name) + (lisp-arg-types t + ;; FIXME: It should be something + ;; like `(ALIEN ,ARG-TYPE), except + ;; for we also accept SAPs where + ;; pointers are required. + ))) + (when (or (eq style :out) (eq style :in-out)) + (results name) + (lisp-result-types `(alien ,type))))))) `(progn ;; The theory behind this automatic DECLAIM is that (1) if ;; you're calling C, static typing is what you're doing @@ -826,13 +834,13 @@ (defun ,lisp-name ,(lisp-args) ,@(docs) (with-alien - ((,lisp-name (function ,result-type ,@(arg-types)) + ((,local-name (function ,result-type ,@(arg-types)) :extern ,alien-name) ,@(alien-vars)) ,@(if (eq 'void result-type) - `((alien-funcall ,lisp-name ,@(alien-args)) + `((alien-funcall ,local-name ,@(alien-args)) (values nil ,@(results))) - `((values (alien-funcall ,lisp-name ,@(alien-args)) + `((values (alien-funcall ,local-name ,@(alien-args)) ,@(results)))))))))) (defun alien-typep (object type) diff -Nru sbcl-2.1.1/src/code/target-char.lisp sbcl-2.1.11/src/code/target-char.lisp --- sbcl-2.1.1/src/code/target-char.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-char.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,12 +20,11 @@ (deftype char-code () `(integer 0 (,char-code-limit))) -(define-load-time-global **unicode-character-name-huffman-tree** ()) - (declaim (inline pack-3-codepoints)) -(defun pack-3-codepoints (first &optional (second 0) (third 0)) - (declare (type (unsigned-byte 21) first second third)) - (sb-c::mask-signed-field 63 (logior first (ash second 21) (ash third 42)))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun pack-3-codepoints (first &optional (second 0) (third 0)) + (declare (type (unsigned-byte 21) first second third)) + (sb-c::mask-signed-field 63 (logior first (ash second 21) (ash third 42))))) (defun unpack-3-codepoints (codepoints) (declare (type (signed-byte 63) codepoints)) @@ -39,103 +38,94 @@ (code-char (ldb (byte 21 21) codepoints)) (code-char (ldb (byte 21 (* 21 2)) codepoints)))))) +(declaim (inline clear-flag)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun clear-flag (bit integer) + (logandc2 integer (ash 1 bit)))) + +(eval-when (:compile-toplevel) + (defconstant +misc-width+ 9) + (defmacro misc-index-from-char-code (codepoint high-pages low-pages) + `(let* ((cp ,codepoint) + (cp-high (ash cp -8)) + (high-index (aref ,high-pages cp-high))) + (if (logbitp 15 high-index) + (* ,+misc-width+ (clear-flag 15 high-index)) + (* ,+misc-width+ (aref ,low-pages (* 2 (+ (ldb (byte 8 0) cp) (ash high-index 8)))))))) + (setf (sb-xc:macro-function 'misc-index-from-char-code) + (lambda (form env) + (declare (ignore env)) + (funcall (cl:macro-function 'misc-index-from-char-code) form nil))) +) + (macrolet ((frob () - (flet ((coerce-it (array) - (coerce array '(simple-array (unsigned-byte 8) 1))) - (file (name type) - (let ((dir (sb-cold:prepend-genfile-path "output/"))) - (make-pathname :directory (pathname-directory (merge-pathnames dir)) - :name name :type type))) + (flet ((file (name type) + (sb-cold:find-bootstrap-file (format nil "output/~A.~A" name type))) (read-ub8-vector (pathname) (with-open-file (stream pathname :element-type '(unsigned-byte 8)) (let* ((length (file-length stream)) (array (sb-xc:make-array - length :element-type '(unsigned-byte 8)))) + length :element-type '(unsigned-byte 8) + :retain-specialization-for-after-xc-core t))) (read-sequence array stream) array))) - (init-global (name type &optional length) - `(progn - (define-load-time-global ,name - ,(if (eql type 'hash-table) - `(make-hash-table) - `(make-array ,length :element-type ',type))) - (declaim (type ,(if (eql type 'hash-table) - 'hash-table - `(simple-array ,type (,length))) ,name))))) - (let ((misc-database (read-ub8-vector (file "ucdmisc" "dat"))) + (make-ubn-vector (raw-bytes n) + (let* ((et (if (= n 3) + '(unsigned-byte 31) + `(unsigned-byte ,(* 8 n)))) + (array (sb-xc:make-array (/ (length raw-bytes) n) + :element-type et + :retain-specialization-for-after-xc-core t))) + (loop for i from 0 below (length raw-bytes) by n + do (loop with element = 0 + for offset from 0 below n + do (incf element (ash (aref raw-bytes (+ i offset)) + (* 8 (- n offset 1)))) + finally (setf (aref array (/ i n)) element))) + array))) + (let* ((misc-database (read-ub8-vector (file "ucdmisc" "dat"))) (ucd-high-pages (read-ub8-vector (file "ucdhigh" "dat"))) (ucd-low-pages (read-ub8-vector (file "ucdlow" "dat"))) (decompositions (read-ub8-vector (file "decomp" "dat"))) (primary-compositions (read-ub8-vector (file "comp" "dat"))) (case-data (read-ub8-vector (file "case" "dat"))) (case-pages (read-ub8-vector (file "casepages" "dat"))) - (collations (read-ub8-vector (file "collation" "dat")))) + (collations (read-ub8-vector (file "collation" "dat"))) + (high-pages (make-ubn-vector ucd-high-pages 2)) + (low-pages (make-ubn-vector ucd-low-pages 2)) + (%*character-case-pages*% (make-ubn-vector case-pages 1))) + `(progn - ;; KLUDGE: All temporary values, fixed up in cold-load - ,(init-global '**character-misc-database** '(unsigned-byte 8) - (length misc-database)) - ,(init-global '**character-high-pages** '(unsigned-byte 16) - (/ (length ucd-high-pages) 2)) - ,(init-global '**character-low-pages** '(unsigned-byte 16) - (/ (length ucd-low-pages) 2)) - ,(init-global '**character-decompositions** '(unsigned-byte 21) - (/ (length decompositions) 3)) - ,(init-global '**character-case-pages** '(unsigned-byte 8) - (length case-pages)) - ,(init-global '**character-primary-compositions** 'hash-table) - ,(init-global '**character-unicode-cases** t - (* 64 (1+ (aref case-pages - (1- (length case-pages)))))) - ,(init-global '**character-cases** '(unsigned-byte 32) - (* 2 64 (1+ (aref case-pages - (1- (length case-pages)))))) - ,(init-global '**character-collations** 'hash-table) - - (defun !character-database-cold-init () - (flet ((make-ubn-vector (raw-bytes n) - (let ((new-array - (make-array - (/ (length raw-bytes) n) - :element-type `(unsigned-byte ,(* 8 n))))) - (loop for i from 0 below (length raw-bytes) by n - for element = 0 do - (loop for offset from 0 below n do - (incf element - (ash (aref raw-bytes (+ i offset)) - (* 8 (- n offset 1))))) - (setf (aref new-array (/ i n)) element)) - new-array))) - (setf **character-misc-database** - ,misc-database - **character-high-pages** - (make-ubn-vector ,ucd-high-pages 2) - **character-low-pages** - (make-ubn-vector ,ucd-low-pages 2) - **character-case-pages** - ,(coerce-it case-pages) - **character-decompositions** - (make-ubn-vector ,decompositions 3)) - - (setf **character-primary-compositions** - (let* ((info (make-ubn-vector ,primary-compositions 3)) - (table (make-hash-table #+64-bit :test #+64-bit #'eq - :size (/ (length info) 3)))) - (dotimes (i (/ (length info) 3)) - (setf (gethash (dpb (aref info (* 3 i)) (byte 21 21) - (aref info (1+ (* 3 i)))) - table) - (aref info (+ (* 3 i) 2)))) - table)) + (defconstant-eqx sb-unicode::+character-misc-database+ ,misc-database #'equalp) + (defconstant-eqx sb-unicode::+character-high-pages+ ,high-pages #'equalp) + (defconstant-eqx sb-unicode::+character-low-pages+ ,low-pages #'equalp) + (defconstant-eqx sb-unicode::+character-decompositions+ + ,(make-ubn-vector decompositions 3) #'equalp) + (defconstant-eqx +character-case-pages+ ,%*character-case-pages*% #'equalp) + (declaim (hash-table **character-primary-compositions**)) + (define-load-time-global **character-primary-compositions** + ,(let ((info (make-ubn-vector primary-compositions 3)) + (alist)) + (dotimes (i (/ (length info) 3)) + (let* ((3i (* 3 i)) + (key (dpb (aref info 3i) (byte 21 21) (aref info (1+ 3i)))) + (value (aref info (+ 3i 2)))) + (push (cons key value) alist))) + `(%stuff-hash-table (make-hash-table #+64-bit :test #+64-bit #'eq + :size ,(/ (length info) 3)) + ,(nreverse (coerce alist 'vector))))) - (let* ((unicode-table + ,@(let* ((unicode-table (make-array - (* 64 (1+ (aref **character-case-pages** - (1- (length **character-case-pages**))))))) - (table (make-array + (* 64 (1+ (aref %*character-case-pages*% + (1- (length %*character-case-pages*%))))) + :initial-element 0)) + (table (sb-xc:make-array (* 2 (length unicode-table)) + :retain-specialization-for-after-xc-core t :element-type '(unsigned-byte 32))) - (info ,case-data) + (info case-data) (index 0) (length (length info))) (labels ((read-codepoint () @@ -158,7 +148,7 @@ for key = (read-codepoint) for upper = (read-length-tagged) for lower = (read-length-tagged) - for page = (aref **character-case-pages** (ash key -6)) + for page = (aref %*character-case-pages*% (ash key -6)) for i = (+ (ash page 6) (ldb (byte 6 0) key)) do (setf (aref unicode-table i) @@ -168,32 +158,31 @@ (dpb upper (byte 21 21) lower))) when (flet (#+sb-unicode - (both-case-p (code) - (logbitp 7 (aref **character-misc-database** - (+ 5 (misc-index (code-char code))))))) + (both-case-p-local (code) + (logbitp 7 (aref misc-database + (+ 5 (misc-index-from-char-code + code high-pages low-pages)))))) (and (atom upper) (atom lower) ;; Some characters are only equal under unicode rules, ;; e.g. #\MICRO_SIGN and #\GREEK_CAPITAL_LETTER_MU #+sb-unicode - (both-case-p lower) + (both-case-p-local lower) #+sb-unicode - (both-case-p upper))) + (both-case-p-local upper))) do (setf (aref table (* i 2)) lower (aref table (1+ (* i 2))) upper))) - (setf **character-unicode-cases** unicode-table) - (setf **character-cases** table)) + `((defconstant-eqx +character-unicode-cases+ ,unicode-table #'equalp) + (defconstant-eqx +character-cases+ ,table #'equalp))) - (setf **character-collations** - (let* ((n-entries - ,(let ((n-entries-file (file "n-collation-entries" "lisp-expr"))) - (with-open-file (s n-entries-file) - (read s)))) - (table (make-hash-table :size n-entries - #+64-bit :test #+64-bit #'eq)) + (define-load-time-global **character-collations** + ,(let* ((n-entries + (with-open-file (s (file "n-collation-entries" "lisp-expr")) + (read s))) + (table) (index 0) - (info (make-ubn-vector ,collations 4)) + (info (make-ubn-vector collations 4)) (len (length info))) (loop while (< index len) do (let* ((entry-head (aref info index)) @@ -212,13 +201,15 @@ (incf index)) ;; verify the validity of ;; :test 'eq on 64-bit - #+64-bit (aver (typep (apply #'pack-3-codepoints codepoints) 'fixnum)) - (setf (gethash (apply #'pack-3-codepoints codepoints) table) - key))) - (aver (= (hash-table-count table) n-entries)) - table)))) + #+64-bit (aver (sb-xc:typep (apply #'pack-3-codepoints codepoints) + 'sb-xc:fixnum)) + (push (cons (apply #'pack-3-codepoints codepoints) key) table))) + (aver (= (length table) n-entries)) + `(%stuff-hash-table + (make-hash-table :size ,n-entries #+64-bit :test #+64-bit #'eq) + ,(nreverse (coerce table 'vector))))) - ,(with-open-file + ,@(with-open-file (stream (file "ucd-names" "lisp-expr")) (with-open-file (u1-stream (file "ucd1-names" "lisp-expr")) (flet ((convert-to-double-vector (vector &optional reversed) @@ -281,28 +272,18 @@ (sort (copy-seq code->u1-name) #'< :key #'cdr) code->u1-name (sort (copy-seq u1-name->code) #'< :key #'car)) - `(progn - ,(init-global '**unicode-char-name-database** t - (* 2 (length code->name))) - ,(init-global '**unicode-name-char-database** t - (* 2 (length name->code))) - ,(init-global '**unicode-1-char-name-database** t - (* 2 (length code->u1-name))) - ,(init-global '**unicode-1-name-char-database** t - (* 2 (length u1-name->code))) - (defun !character-name-database-cold-init () - (setf **unicode-character-name-huffman-tree** ',tree - **unicode-char-name-database** - ',(convert-to-double-vector code->name) - **unicode-name-char-database** - ',(convert-to-double-vector name->code t) - **unicode-1-char-name-database** - ',(convert-to-double-vector code->u1-name) - **unicode-1-name-char-database** - ',(convert-to-double-vector u1-name->code t)))))))))))))) + `((defconstant-eqx +unicode-char-name-database+ + ,(convert-to-double-vector code->name) #'equalp) + (defconstant-eqx +unicode-name-char-database+ + ,(convert-to-double-vector name->code t) #'equalp) + (defconstant-eqx sb-unicode::+unicode-1-char-name-database+ + ,(convert-to-double-vector code->u1-name) #'equalp) + (defconstant-eqx +unicode-1-name-char-database+ + ,(convert-to-double-vector u1-name->code t) #'equalp) + (defconstant-eqx sb-unicode::+unicode-character-name-huffman-tree+ + ',tree #'equal)))))))))))) (frob)) -#+sb-xc-host (!character-name-database-cold-init) (define-load-time-global *base-char-name-alist* ;; Note: The *** markers here indicate character names which are @@ -379,8 +360,8 @@ ;;;; UCD accessor functions ;;; The character database is made of several arrays. -;;; **CHARACTER-MISC-DATABASE** is an array of bytes that encode character -;;; attributes. Each entry in the misc database is +misc-width+ (currently 8) +;;; +CHARACTER-MISC-DATABASE+ is an array of bytes that encode character +;;; attributes. Each entry in the misc database is +misc-width+ (currently 9) ;;; bytes wide. Within each entry, the bytes represent: general category, BIDI ;;; class, canonical combining class, digit value, decomposition info, other ;;; flags, script, line break class, and age, respectively. Several of the @@ -399,23 +380,23 @@ ;;; the minor version in bits 0-2, and the major version in the remaining 5 ;;; bits. ;;; -;;; To find which entry in **CHARACTER-MISC-DATABASE** encodes a character's -;;; attributes, first index **CHARACTER-HIGH-PAGES** (an array of 16-bit +;;; To find which entry in +CHARACTER-MISC-DATABASE+ encodes a character's +;;; attributes, first index +CHARACTER-HIGH-PAGES+ (an array of 16-bit ;;; values) with the high 13 bits of the character's codepoint. If the result ;;; value has its high bit set, the character is in a "compressed page". To ;;; find the misc entry number, simply clear the high bit. If the high bit is ;;; not set, the misc entry number must be looked up in -;;; **CHARACTER-LOW-PAGES**, which is an array of 16-bit values. Each entry in +;;; +CHARACTER-LOW-PAGES+, which is an array of 16-bit values. Each entry in ;;; the array consists of two such values, the misc entry number and the ;;; decomposition index. To find the misc entry number, index into -;;; **CHARACTER-LOW-PAGES** using the value retreived from -;;; **CHARACTER-HIGH-PAGES** (shifted left 8 bits) plus the low 8 bits of the +;;; +CHARACTER-LOW-PAGES+ using the value retreived from +;;; +CHARACTER-HIGH-PAGES+ (shifted left 8 bits) plus the low 8 bits of the ;;; codepoint, all times two to account for the widtth of the entries. The -;;; value in **CHARACTER-LOW-PAGES** at this point is the misc entry number. To +;;; value in +CHARACTER-LOW-PAGES+ at this point is the misc entry number. To ;;; transform a misc entry number into an index into -;;; **CHARACTER-MISC-DATABASE**, multiply it by +misc-width*. This gives the +;;; +CHARACTER-MISC-DATABASE+, multiply it by +misc-width*. This gives the ;;; index of the start of the charater's misc entry in -;;; **CHARACTER-MISC-DATABASE**. +;;; +CHARACTER-MISC-DATABASE+. ;;; ;;; To look up a character's decomposition, first retreive its ;;; decomposition-info from the misc database as described above. If the @@ -429,7 +410,7 @@ ;;; index, are the decomposition of the character. This proceduce does not ;;; apply to Hangul syllables, which have their own decomposition algorithm. ;;; -;;; Case information is stored in **CHARACTER-UNICODE-CASES**, an array that +;;; Case information is stored in +CHARACTER-UNICODE-CASES+, an array that ;;; indirectly maps a character's codepoint to (cons uppercase ;;; lowercase). Uppercase and lowercase are either a single codepoint, ;;; which is the upper- or lower-case of the given character, or a @@ -437,7 +418,7 @@ ;;; lower-case. These case lists are only used in Unicode case ;;; transformations, not in Common Lisp ones. ;;; -;;; **CHARACTER-CASES** is similar to the above but it stores codes in +;;; +CHARACTER-CASES+ is similar to the above but it stores codes in ;;; a flat array twice as large, and it includes only the standard casing rules, ;;; so there's always just two characters. ;;; @@ -445,30 +426,19 @@ ;;; which is a hash table of codepoints indexed by (+ (ash codepoint1 21) ;;; codepoint2). -(declaim (inline clear-flag)) -(defun clear-flag (bit integer) - (logandc2 integer (ash 1 bit))) - -(defconstant +misc-width+ 9) - (declaim (ftype (sfunction (t) (unsigned-byte 16)) misc-index)) (defun misc-index (char) - (let* ((cp (char-code char)) - (cp-high (ash cp -8)) - (high-index (aref **character-high-pages** cp-high))) - (if (logbitp 15 high-index) - (* +misc-width+ (clear-flag 15 high-index)) - (* +misc-width+ - (aref **character-low-pages** - (* 2 (+ (ldb (byte 8 0) cp) (ash high-index 8)))))))) + (misc-index-from-char-code (char-code char) + sb-unicode::+character-high-pages+ + sb-unicode::+character-low-pages+)) (declaim (ftype (sfunction (t) (unsigned-byte 8)) ucd-general-category) (inline ucd-general-category)) (defun ucd-general-category (char) - (aref **character-misc-database** (misc-index char))) + (aref sb-unicode::+character-misc-database+ (misc-index char))) (defun ucd-decimal-digit (char) - (let ((digit (aref **character-misc-database** + (let ((digit (aref sb-unicode::+character-misc-database+ (+ 3 (misc-index char))))) (when (logbitp 6 digit) ; decimalp flag (ldb (byte 4 0) digit)))) @@ -514,10 +484,10 @@ (let ((char-code (char-code char))) (or (second (assoc char-code *base-char-name-alist*)) (let ((h-code (double-vector-binary-search char-code - **unicode-char-name-database**))) + +unicode-char-name-database+))) (cond (h-code - (huffman-decode h-code **unicode-character-name-huffman-tree**)) + (huffman-decode h-code sb-unicode::+unicode-character-name-huffman-tree+)) (t (format nil "U~X" char-code))))))) @@ -540,14 +510,14 @@ (code-char (parse-integer name :start start :radix 16))))) (t (let ((encoding (huffman-encode (string-upcase name) - **unicode-character-name-huffman-tree**))) + sb-unicode::+unicode-character-name-huffman-tree+))) (when encoding (let ((char-code (or (double-vector-binary-search encoding - **unicode-name-char-database**) + +unicode-name-char-database+) (double-vector-binary-search encoding - **unicode-1-name-char-database**)))) + +unicode-1-name-char-database+)))) (and char-code (code-char char-code))))))))) @@ -582,20 +552,19 @@ (defmacro with-case-info ((char index-var cases-var &key miss-value - (cases '**character-cases**) - (case-pages '**character-case-pages**)) + (cases '+character-cases+)) &body body) (let ((code-var (gensym "CODE")) (shifted-var (gensym "SHIFTED")) (page-var (gensym "PAGE"))) `(block nil (locally - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (let ((,code-var (char-code ,char))) (let* ((,shifted-var (ash ,code-var -6)) - (,page-var (if (>= ,shifted-var (length **character-case-pages**)) + (,page-var (if (>= ,shifted-var (length +character-case-pages+)) (return ,miss-value) - (aref ,case-pages ,shifted-var)))) + (aref +character-case-pages+ ,shifted-var)))) (if (= ,page-var 255) ,miss-value (let ((,index-var (* (+ (ash ,page-var 6) @@ -660,10 +629,10 @@ (declaim (inline char-case-info)) (defun char-case-info (character) (let* ((code (char-code character)) - (page (aref **character-case-pages** (ash code -6)))) + (page (aref +character-case-pages+ (ash code -6)))) ;; Pages with 255 means the character is not both-case. - ;; **character-cases** has 0 for those characters. - (aref **character-unicode-cases** + ;; +CHARACTER-CASES+ has 0 for those characters. + (aref +character-unicode-cases+ (+ (ash page 6) (ldb (byte 6 0) code))))) @@ -672,13 +641,13 @@ (defun equal-char-code (char) (let* ((code (char-code char)) (shifted (ash code -6)) - (page (if (>= shifted (length **character-case-pages**)) + (page (if (>= shifted (length +character-case-pages+)) (return-from equal-char-code code) - (aref **character-case-pages** shifted)))) + (aref +character-case-pages+ shifted)))) (if (= page 255) code (let ((down-code - (aref **character-cases** + (aref +character-cases+ (* (+ (ash page 6) (ldb (byte 6 0) code)) 2)))) diff -Nru sbcl-2.1.1/src/code/target-defstruct.lisp sbcl-2.1.11/src/code/target-defstruct.lisp --- sbcl-2.1.1/src/code/target-defstruct.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-defstruct.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,36 +13,214 @@ ;;;; structure frobbing primitives +;;; For lack of any better to place to write up some detail surrounding +;;; layout creation for structure types, I'm putting here. +;;; When you issue a DEFSTRUCT at the REPL, there are *three* instances +;;; of LAYOUT makde for the new structure. +;;; 1) The first is one associated with a temporary instance of +;;; structure-classoid used in parsing the DEFSTRUCT form so that +;;; we don't signal an UNKNOWN-TYPE condition for something like: +;;; (defstruct chain (next nil :type (or null chain)). +;;; The temporary classoid is garbage immediately after parsing +;;; and is never installed. +;;; 2) The next is the actual LAYOUT that ends up being registered. +;;; 3) The third is a layout created when setting the "compiler layout" +;;; which contains copies of the length/depthoid/inherits etc +;;; that we compare against the installed one to make sure they match. +;;; The third one also gets thrown away. +(define-load-time-global *layout-id-generator* (cons 0 nil)) +(declaim (type (cons fixnum) *layout-id-generator*)) +;;; NB: for #+metaspace this returns a WRAPPER, not a LAYOUT. +(defun make-layout (clos-hash classoid + &key (depthoid -1) (length 0) (flags 0) + (inherits #()) + (info nil) + (bitmap (if info (dd-bitmap info) 0)) + (invalid :uninitialized) + &aux (id (or (atomic-pop (cdr *layout-id-generator*)) + (atomic-incf (car *layout-id-generator*))))) + (unless (typep id '(and layout-id (not (eql 0)))) + (error "Layout ID limit reached")) + (let* ((fixed-words (type-dd-length sb-vm:layout)) + (extra-id-words ; count of additional words needed to store ancestors + (if (logtest flags +structure-layout-flag+) + (calculate-extra-id-words depthoid) + 0)) + (bitmap-words (ceiling (1+ (integer-length bitmap)) sb-vm:n-word-bits)) + (nwords (+ fixed-words extra-id-words bitmap-words)) + (layout + (truly-the sb-vm:layout + #-(or metaspace immobile-space) (%make-instance nwords) + #+metaspace (sb-vm::allocate-metaspace-chunk (1+ nwords)) + #+(and immobile-space (not metaspace)) + (sb-vm::alloc-immobile-fixedobj + (1+ nwords) + (logior (ash nwords sb-vm:instance-length-shift) + sb-vm:instance-widetag)))) + (wrapper #-metaspace layout)) + (%set-instance-layout layout + (wrapper-friend #.(find-layout #+metaspace 'sb-vm:layout + #-metaspace 'wrapper))) + #+metaspace + (setf wrapper (%make-wrapper :clos-hash clos-hash :classoid classoid + :%info info :invalid invalid :friend layout) + (layout-friend layout) wrapper) + (setf (layout-flags layout) #+64-bit (pack-layout-flags depthoid length flags) + #-64-bit flags) + (setf (layout-clos-hash layout) clos-hash + (wrapper-classoid wrapper) classoid + (wrapper-invalid wrapper) invalid) + #-64-bit (setf (wrapper-depthoid wrapper) depthoid + (wrapper-length wrapper) length) + #-metaspace (setf (wrapper-%info wrapper) info ; already set if #+metaspace + (wrapper-slot-table wrapper) #(1 nil)) + (set-layout-inherits wrapper inherits (logtest flags +structure-layout-flag+) id) + (let ((bitmap-base (+ fixed-words extra-id-words))) + (dotimes (i bitmap-words) + (%raw-instance-set/word layout (+ bitmap-base i) + (ldb (byte sb-vm:n-word-bits (* i sb-vm:n-word-bits)) bitmap)))) + ;; It's not terribly important that we recycle layout IDs, but I have some other + ;; changes planned that warrant a finalizer per layout. + ;; FIXME: structure IDs should never be recycled because code blobs referencing + ;; th ID do not reference the layout, and so the layout could be GCd allowing + ;; reuse of an old ID for a new type. + (unless (built-in-classoid-p classoid) + (let ((layout-addr (- (get-lisp-obj-address layout) sb-vm:instance-pointer-lowtag))) + (declare (ignorable layout-addr)) + (finalize wrapper + (lambda () + #+metaspace (sb-vm::unallocate-metaspace-chunk layout-addr) + (atomic-push id (cdr *layout-id-generator*))) + :dont-save t))) + ;; Rather than add and delete this line of debugging which I've done so many times, + ;; let's instead keep it but commented out. + #+nil + (alien-funcall (extern-alien "printf" (function void system-area-pointer unsigned unsigned + unsigned system-area-pointer)) + (vector-sap #.(format nil "New wrapper ID=%d %p %p '%s'~%")) + id (get-lisp-obj-address layout) (get-lisp-obj-address wrapper) + (vector-sap (string (classoid-name classoid)))) + wrapper)) + +#+metaspace +(defun make-temporary-wrapper (clos-hash classoid inherits) + (let* ((layout (%make-temporary-layout #.(find-layout t) clos-hash)) + (wrapper (%make-wrapper :clos-hash clos-hash :classoid classoid + :inherits inherits :invalid nil + :friend layout))) + (setf (layout-friend layout) wrapper) + wrapper)) + +;;; This allocator is used by the expansion of MAKE-LOAD-FORM-SAVING-SLOTS +;;; when given a STRUCTURE-OBJECT. +(defun allocate-struct (type) + (let* ((wrapper (classoid-wrapper (the structure-classoid (find-classoid type)))) + (structure (%make-instance (wrapper-length wrapper)))) + (setf (%instance-wrapper structure) wrapper) + (dolist (dsd (dd-slots (wrapper-dd wrapper)) structure) + (when (eq (dsd-raw-type dsd) 't) + (%instance-set structure (dsd-index dsd) (make-unbound-marker)))))) + ;;; Return the value from the INDEXth slot of INSTANCE. This is SETFable. ;;; This is used right away in warm compile by MAKE-LOAD-FORM-SAVING-SLOTS, ;;; so without it already defined, you can't define it, because you can't dump ;;; debug info structures. Were it not for that, this would go in 'stubs'. (defun %instance-ref (instance index) (%instance-ref instance index)) +(defun (setf %instance-ref) (newval instance index) + (%instance-set instance index newval) + newval) +#.`(progn + ,@(map 'list + (lambda (rsd) + (let* ((reader (sb-kernel::raw-slot-data-reader-name rsd)) + (writer (sb-kernel::raw-slot-data-writer-name rsd)) + (type (sb-kernel::raw-slot-data-raw-type rsd))) + `(progn + (defun ,reader (instance index) (,reader instance index)) + ;; create a well-behaving SETF-compatible slot setter + (defun (setf ,reader) (newval instance index) + (declare (,type newval)) + (,writer instance index newval) + newval) + ;; .. and a non-SETF-compatible one + (defun ,writer (instance index newval) + (declare (,type newval)) + (,writer instance index newval) + (values))))) + sb-kernel::*raw-slot-data*)) + +(macrolet ((id-bits-sap () + `(sap+ (int-sap (get-lisp-obj-address layout)) + ,(- (sb-vm::id-bits-offset) sb-vm:instance-pointer-lowtag)))) +(defun layout-id (layout) + ;; If a structure type at depthoid >= 2, then fetch the INDEXth id + ;; where INDEX is depthoid - 2. Otherwise fetch the 0th id. + ;; There are a few non-structure types at positive depthoid; those do not store + ;; their ancestors in the vector; they only store self-id at index 0. + ;; This isn't performance-critical. If it were, then we should store self-ID + ;; at a fixed index. Using it for type-based dispatch remains a possibility. + (let* ((layout (cond #+metaspace ((typep layout 'wrapper) (wrapper-friend layout)) + (t layout))) + (depth (- (sb-vm::layout-depthoid layout) 2)) + (index (if (or (< depth 0) (not (logtest (layout-flags layout) + +structure-layout-flag+))) + 0 depth))) + (truly-the layout-id + #-64-bit (%raw-instance-ref/signed-word + layout (+ (get-dsd-index sb-vm:layout id-word0) index)) + #+64-bit ; use SAP-ref for lack of half-sized slots + (with-pinned-objects (layout) + (signed-sap-ref-32 (id-bits-sap) (ash index 2)))))) + +(defun set-layout-inherits (wrapper inherits structurep this-id + &aux (layout (wrapper-friend wrapper))) + (setf (wrapper-inherits wrapper) inherits) + ;;; If structurep, and *only* if, store all the inherited layout IDs. + ;;; It looks enticing to try to always store "something", but that goes wrong, + ;;; because only structure-object layouts are growable, and only structure-object + ;;; can store the self-ID in the proper index. + ;;; If the depthoid is -1, the self-ID has to go in index 0. + ;;; Standard-object layouts are not growable. The inherited layouts are known + ;;; only at class finalization time, at which point we've already made the layout. + ;;; Hence, the required indirection to the simple-vector of inherits. + (with-pinned-objects (layout) + ;; The layout-id vector is an array of int32_t starting at the ID-WORD0 slot. + ;; We could use (SETF %RAW-INSTANCE-REF/WORD) for 32-bit architectures, + ;; but on 64-bit we have to use SAP-REF, so may as well be consistent here + ;; and use a SAP either way. + (let ((sap (id-bits-sap))) + (cond (structurep + (loop for i from 0 by 4 + for j from 2 below (length inherits) ; skip T and STRUCTURE-OBJECT + do (setf (signed-sap-ref-32 sap i) (layout-id (svref inherits j))) + finally (setf (signed-sap-ref-32 sap i) this-id))) + ((not (eql this-id 0)) + (setf (signed-sap-ref-32 sap 0) this-id)))))) +) ; end MACROLET ;;; Normally IR2 converted, definition needed for interpreted structure ;;; constructors only. +;;; [Hmm, do we correctly type-check in the call to the constructor? +;;; Because this sure as heck doesn't check anything] #+(or sb-eval sb-fasteval) (defun %make-structure-instance (dd slot-specs &rest slot-values) (let ((instance (%make-instance (dd-length dd))) ; length = sans header word (value-index 0)) (declare (index value-index)) - (setf (%instance-layout instance) (dd-layout-or-lose dd)) + (setf (%instance-wrapper instance) (dd-layout-or-lose dd)) (dolist (spec slot-specs instance) (destructuring-bind (kind raw-type . index) spec (if (eq kind :unbound) - (setf (%instance-ref instance index) - (sb-sys:%primitive make-unbound-marker)) + (%instance-set instance index (make-unbound-marker)) (macrolet ((make-case () `(ecase raw-type - ((t) - (setf (%instance-ref instance index) value)) + ((t) (%instance-set instance index value)) ,@(map 'list (lambda (rsd) `(,(raw-slot-data-raw-type rsd) - (setf (,(raw-slot-data-accessor-name rsd) - instance index) - value))) + (,(raw-slot-data-writer-name rsd) + instance index value))) *raw-slot-data*)))) (let ((value (fast-&rest-nth value-index slot-values))) (incf value-index) @@ -53,13 +231,15 @@ ;;; A list of hooks designating functions of one argument, the ;;; classoid, to be called when a defstruct is evaluated. -(!define-load-time-global *defstruct-hooks* nil) +(define-load-time-global *defstruct-hooks* nil) ;;; the part of %DEFSTRUCT which makes sense only on the target SBCL ;;; +(defmacro set-wrapper-equalp-impl (wrapper newval) + `(%instance-set ,wrapper (get-dsd-index wrapper equalp-impl) ,newval)) + (defun assign-equalp-impl (type-name function) - (setf (%instance-ref (find-layout type-name) (get-dsd-index layout equalp-impl)) - function)) + (set-wrapper-equalp-impl (find-layout type-name) function)) (defun %target-defstruct (dd equalp) (declare (type defstruct-description dd)) @@ -68,12 +248,12 @@ (setf (documentation (dd-name dd) 'structure) (dd-doc dd))) - (let* ((classoid (find-classoid (dd-name dd))) - (layout (classoid-layout classoid))) - (setf (%instance-ref layout (get-dsd-index sb-kernel:layout sb-kernel::equalp-impl)) + (let ((classoid (find-classoid (dd-name dd)))) + (let ((layout (classoid-wrapper classoid))) + (set-wrapper-equalp-impl + layout (cond ((compiled-function-p equalp) equalp) - ((eql (layout-bitmap layout) +layout-all-tagged+) - #'sb-impl::instance-equalp) + ((eql (dd-bitmap dd) +layout-all-tagged+) #'sb-impl::instance-equalp) (t ;; Make a vector of EQUALP slots comparators, indexed by ;; (- word-index INSTANCE-DATA-START). @@ -97,10 +277,11 @@ 0 ; means recurse using EQUALP (raw-slot-data-comparator rsd))))) (lambda (a b) - (sb-impl::instance-equalp* comparators a b)))))) + (sb-impl::instance-equalp* comparators a b))))))) - (dolist (fun *defstruct-hooks*) - (funcall fun classoid))) + (when *type-system-initialized* + (dolist (fun *defstruct-hooks*) + (funcall fun classoid)))) (dd-name dd)) @@ -108,8 +289,8 @@ (defun copy-structure (structure) "Return a copy of STRUCTURE with the same (EQL) slot values." (declare (type structure-object structure)) - (let ((layout (%instance-layout structure))) - (when (layout-invalid layout) + (let ((wrapper (%instance-wrapper structure))) + (when (wrapper-invalid wrapper) (error "attempt to copy an obsolete structure:~% ~S" structure)) ;; Previously this had to used LAYOUT-LENGTH in the allocation, ;; to avoid copying random bits from the stack to the heap if you had a @@ -120,9 +301,9 @@ (let* ((len (%instance-length structure)) (res (%make-instance len))) (declare (type index len)) - (let ((bitmap (layout-bitmap layout))) + (let ((bitmap (dd-bitmap (wrapper-dd wrapper)))) ;; Don't assume that %INSTANCE-REF can access the layout. - (setf (%instance-layout res) (%instance-layout structure)) + (%set-instance-layout res (%instance-layout structure)) ;; On backends which don't segregate descriptor vs. non-descriptor ;; registers, we could speed up this code in an obvious way. (macrolet ((copy-loop (tagged-p &optional step) @@ -130,9 +311,8 @@ ((>= i len)) (declare (index i)) (if ,tagged-p - (setf (%instance-ref res i) - (%instance-ref structure i)) - (setf (%raw-instance-ref/word res i) + (%instance-set res i (%instance-ref structure i)) + (%raw-instance-set/word res i (%raw-instance-ref/word structure i))) ,step))) (cond ((eql bitmap +layout-all-tagged+) (copy-loop t)) @@ -148,16 +328,22 @@ ;;; this won't ever be called. (defun %copy-instance (to from) (declare (structure-object to from) (optimize (safety 0))) - (setf (%instance-layout to) (%instance-layout from)) + (%set-instance-layout to (%instance-layout from)) (dotimes (i (%instance-length to) to) - (setf (%instance-ref to i) (%instance-ref from i)))) + (%instance-set to i (%instance-ref from i)))) ;;; Like %COPY-INSTANCE, but layout was already assigned. ;;; Similarly, will not be called if raw slots and precise GC. (defun %copy-instance-slots (to from) (declare (structure-object to from) (optimize (safety 0))) (loop for i from sb-vm:instance-data-start below (%instance-length to) - do (setf (%instance-ref to i) (%instance-ref from i))) + do (%instance-set to i (%instance-ref from i))) to) +(defun (setf %instance-wrapper) (newval x) + (%set-instance-layout x (wrapper-friend newval)) + newval) +(defun (setf %fun-wrapper) (newval x) + (%set-fun-layout x (wrapper-friend newval)) + newval) ;;; default PRINT-OBJECT method @@ -215,9 +401,9 @@ (declare (ignore depth)) (if (funcallable-instance-p structure) (print-unreadable-object (structure stream :identity t :type t)) - (let* ((layout (%instance-layout structure)) - (dd (layout-info layout)) - (name (layout-classoid-name layout))) + (let* ((wrapper (%instance-wrapper structure)) + (dd (wrapper-info wrapper)) + (name (wrapper-classoid-name wrapper))) (cond ((not dd) ;; FIXME? this branch may be unnecessary as a consequence ;; of change f02bee325920166b69070e4735a8a3f295f8edfd which @@ -267,5 +453,32 @@ ,(+ (- sb-vm:instance-pointer-lowtag) (* (+ sb-vm:instance-slots-offset index) sb-vm:n-word-bytes)))))))) + +#+metaspace +(defmethod print-object ((self sb-vm:layout) stream) + (print-unreadable-object (self stream :type t :identity t) + (write (layout-id self) :stream stream))) + +(defun id-to-layout (id) + (maphash (lambda (k v) + (declare (ignore k)) + (when (eql (layout-id v) id) + (return-from id-to-layout (wrapper-friend v)))) + (classoid-subclasses (find-classoid 't)))) +(export 'id-to-layout) + +(defun summarize-layouts () + (flet ((flag-bits (x) (logand (layout-flags (wrapper-friend x)) + layout-flags-mask))) + (let ((prev -1)) + (dolist (layout (sort (loop for v being each hash-value + of (classoid-subclasses (find-classoid 't)) + collect v) + #'> :key #'flag-bits)) + (let ((flags (flag-bits layout))) + (unless (= flags prev) + (format t "Layout flags = #b~10,'0b~%" flags) + (setq prev flags))) + (format t " ~a~%" layout))))) (/show0 "target-defstruct.lisp end of file") diff -Nru sbcl-2.1.1/src/code/target-error.lisp sbcl-2.1.11/src/code/target-error.lisp --- sbcl-2.1.1/src/code/target-error.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-error.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,6 +12,24 @@ (in-package "SB-KERNEL") +(declaim (global *type-system-initialized*)) + +(defun decode-internal-error-args (sap trap-number &optional error-number) + (let ((error-number (cond (error-number) + ((>= trap-number sb-vm:error-trap) + (prog1 + (- trap-number sb-vm:error-trap) + (setf trap-number sb-vm:error-trap))) + (t + (prog1 (sap-ref-8 sap 0) + (setf sap (sap+ sap 1))))))) + (let ((length (error-length error-number))) + (declare (type (unsigned-byte 8) length)) + (values error-number + (loop repeat length with index = 0 + collect (sb-c:sap-read-var-integerf sap index)) + trap-number)))) + (defun muffle-warning-p (warning) (declare (special *muffled-warnings*)) (typep warning *muffled-warnings*)) @@ -204,6 +222,2201 @@ (funcall function condition))))) +;;;; Conditions. + +(!defstruct-with-alternate-metaclass condition + :slot-names (assigned-slots) + :constructor nil + :superclass-name t + :metaclass-name condition-classoid + :metaclass-constructor make-condition-classoid + :dd-type structure) + +;;; Needed for !CALL-A-METHOD to pick out CONDITIONs +(defun !condition-p (x) (typep x 'condition)) + +(defstruct (condition-slot (:copier nil)) + (name (missing-arg) :type symbol) + ;; list of all applicable initargs + (initargs (missing-arg) :type list) + ;; names of reader and writer functions + (readers (missing-arg) :type list) + (writers (missing-arg) :type list) + ;; true if :INITFORM was specified + (initform-p (missing-arg) :type (member t nil)) + ;; the initform if :INITFORM was specified, otherwise NIL + (initform nil :type t) + ;; if this is a function, call it with no args to get the initform value + (initfunction (missing-arg) :type t) + ;; allocation of this slot, or NIL until defaulted + (allocation nil :type (member :instance :class nil)) + ;; If ALLOCATION is :CLASS, this is a cons whose car holds the value + (cell nil :type (or cons null)) + ;; slot documentation + (documentation nil :type (or string null))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (let ((condition-class (find-classoid 'condition))) + (setf (condition-classoid-cpl condition-class) + (list condition-class)))) + +(setf (condition-classoid-report (find-classoid 'condition)) + (lambda (cond stream) + (format stream "Condition ~/sb-impl:print-type-specifier/ was signalled." + (type-of cond)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defun find-condition-layout (name parent-types) + (let* ((cpl (remove-duplicates + (reverse + (reduce #'append + (mapcar (lambda (x) + (condition-classoid-cpl + (find-classoid x))) + parent-types))))) + (cond-layout (info :type :compiler-layout 'condition)) + (olayout (info :type :compiler-layout name)) + ;; FIXME: Does this do the right thing in case of multiple + ;; inheritance? A quick look at DEFINE-CONDITION didn't make + ;; it obvious what ANSI intends to be done in the case of + ;; multiple inheritance, so it's not actually clear what the + ;; right thing is.. + (new-inherits + (order-layout-inherits (concatenate 'simple-vector + (wrapper-inherits cond-layout) + (mapcar #'classoid-wrapper cpl))))) + (if (and olayout + (not (mismatch (wrapper-inherits olayout) new-inherits))) + olayout + ;; All condition classoid layouts carry the same LAYOUT-INFO - the defstruct + ;; description for CONDITION - which is a representation of the primitive object + ;; and not the lisp-level object. + (make-layout (hash-layout-name name) + (make-undefined-classoid name) + :info (wrapper-info cond-layout) + :flags +condition-layout-flag+ + :inherits new-inherits + :depthoid -1 + :length (wrapper-length cond-layout))))) + +) ; EVAL-WHEN + + +;;;; slots of CONDITION objects + +(defun find-slot-default (class slot) + (multiple-value-bind (value found) (find-slot-default-initarg class slot) + ;; When CLASS or a superclass has a default initarg for SLOT, use + ;; that. + (cond (found + value) + ;; Otherwise use the initform of SLOT, if there is one. + ((condition-slot-initform-p slot) + (let ((initfun (condition-slot-initfunction slot))) + (aver (functionp initfun)) + (funcall initfun))) + (t + (error "Unbound condition slot: ~S" (condition-slot-name slot)))))) + +(defun find-slot-default-initarg (class slot) + (let ((initargs (condition-slot-initargs slot)) + (cpl (condition-classoid-cpl class))) + (dolist (class cpl) + (let ((direct-default-initargs + (condition-classoid-direct-default-initargs class))) + (dolist (initarg initargs) + (let ((initfunction (third (assoc initarg direct-default-initargs)))) + (when initfunction + (return-from find-slot-default-initarg + (values (funcall initfunction) t))))))) + (values nil nil))) + +(defun find-condition-class-slot (condition-class slot-name) + (dolist (sclass + (condition-classoid-cpl condition-class) + (error "There is no slot named ~S in ~S." + slot-name condition-class)) + (dolist (slot (condition-classoid-slots sclass)) + (when (eq (condition-slot-name slot) slot-name) + (return-from find-condition-class-slot slot))))) + +(defun set-condition-slot-value (condition new-value name) + (dolist (cslot (condition-classoid-class-slots + (wrapper-classoid (%instance-wrapper condition))) + (setf (getf (condition-assigned-slots condition) name) + new-value)) + (when (eq (condition-slot-name cslot) name) + (return (setf (car (condition-slot-cell cslot)) new-value))))) + +(defun condition-slot-value (condition name) + (let ((val (getf (condition-assigned-slots condition) name sb-pcl:+slot-unbound+))) + (if (unbound-marker-p val) + (let ((class (wrapper-classoid (%instance-wrapper condition)))) + (dolist (cslot + (condition-classoid-class-slots class) + (let ((instance-length (%instance-length condition)) + (slot (or (find-condition-class-slot class name) + (error "missing slot ~S of ~S" name condition)))) + (setf (getf (condition-assigned-slots condition) name) + (do ((i (+ sb-vm:instance-data-start 1) (+ i 2))) + ((>= i instance-length) (find-slot-default class slot)) + (when (member (%instance-ref condition i) + (condition-slot-initargs slot)) + (return (%instance-ref condition (1+ i)))))))) + (when (eq (condition-slot-name cslot) name) + (let ((value (car (condition-slot-cell cslot)))) + (if (unbound-marker-p value) + (error "Unbound condition slot: ~S" (condition-slot-name cslot)) + (return value)))))) + val))) + + +;;;; MAKE-CONDITION + +;;; Pre-scan INITARGS to see whether any are stack-allocated. +;;; If not, then life is easy. If any are, then depending on whether the +;;; condition is a TYPE-ERROR, call TYPE-OF on the bad datum, so that +;;; if the condition outlives the extent of the object, and someone tries +;;; to print the condition, we don't crash. +;;; Putting a placeholder in for the datum would work, but seems a bit evil, +;;; since the user might actually want to know what it was. And we shouldn't +;;; assume that the object would definitely escape its dynamic-extent. + +(defun allocate-condition (designator &rest initargs) + (when (oddp (length initargs)) + (error 'simple-error + :format-control "odd-length initializer list: ~S." + ;; Passing the initargs to LIST avoids consing them into + ;; a list except when this error is signaled. + :format-arguments (list (apply #'list initargs)))) + ;; I am going to assume that people are not somehow getting to here + ;; with a CLASSOID, which is not strictly legal as a designator, + ;; but which is accepted because it is actually the desired thing. + ;; It doesn't seem worth sweating over that detail, and in any event + ;; we could say that it's a supported extension. + (let ((classoid (named-let lookup ((designator designator)) + (typecase designator + (symbol (find-classoid designator nil)) + (class (lookup (class-name designator))) + (t designator))))) + (unless (condition-classoid-p classoid) + (error 'simple-type-error + :datum designator + :expected-type 'sb-pcl::condition-class + :format-control "~S does not designate a condition class." + :format-arguments (list designator))) + (flet ((stream-err-p (layout) + (let ((stream-err-layout (load-time-value (find-layout 'stream-error)))) + (or (eq layout stream-err-layout) + (find stream-err-layout (wrapper-inherits layout))))) + (type-err-p (layout) + (let ((type-err-layout (load-time-value (find-layout 'type-error)))) + (or (eq layout type-err-layout) + (find type-err-layout (wrapper-inherits layout))))) + ;; avoid full calls to STACK-ALLOCATED-P here + (stackp (x) + (let ((addr (get-lisp-obj-address x))) + (and (sb-vm:is-lisp-pointer addr) + (<= (get-lisp-obj-address sb-vm:*control-stack-start*) addr) + (< addr (get-lisp-obj-address sb-vm:*control-stack-end*)))))) + (let* ((any-dx + (loop for arg-index from 1 below (length initargs) by 2 + thereis (stackp (fast-&rest-nth arg-index initargs)))) + (layout (classoid-wrapper classoid)) + (extra (if (and any-dx (type-err-p layout)) 2 0)) ; space for secret initarg + (instance (%make-instance (+ sb-vm:instance-data-start + 1 ; ASSIGNED-SLOTS + (length initargs) + extra))) + (data-index (1+ sb-vm:instance-data-start)) + (arg-index 0) + (have-type-error-datum) + (type-error-datum)) + (setf (%instance-wrapper instance) layout + (condition-assigned-slots instance) nil) + (macrolet ((store-pair (key val) + `(progn (%instance-set instance data-index ,key) + (%instance-set instance (1+ data-index) ,val)))) + (cond ((not any-dx) + ;; uncomplicated way + (loop (when (>= arg-index (length initargs)) (return)) + (store-pair (fast-&rest-nth arg-index initargs) + (fast-&rest-nth (1+ arg-index) initargs)) + (incf data-index 2) + (incf arg-index 2))) + (t + (loop (when (>= arg-index (length initargs)) (return)) + (let ((key (fast-&rest-nth arg-index initargs)) + (val (fast-&rest-nth (1+ arg-index) initargs))) + (when (and (eq key :datum) + (not have-type-error-datum) + (type-err-p layout)) + (setq type-error-datum val + have-type-error-datum t)) + (if (and (eq key :stream) (stream-err-p layout) (stackp val)) + (store-pair key (sb-impl::make-stub-stream val)) + (store-pair key val))) + (incf data-index 2) + (incf arg-index 2)) + (when (and have-type-error-datum (/= extra 0)) + ;; We can get into serious trouble here if the + ;; datum is already stack garbage! + (let ((actual-type (type-of type-error-datum))) + (store-pair 'dx-object-type actual-type)))))) + (values instance classoid))))) + +;;; Access the type of type-error-datum if the datum can't be accessed. +;;; Testing the stack pointer when rendering the condition is a heuristic +;;; that might work, but more likely, the erring frame has been exited +;;; and then the stack pointer changed again to make it seems like the +;;; object pointer is valid. I'm not sure what to do, but we can leave +;;; that decision for later. +(defun type-error-datum-stored-type (condition) + (do ((i (- (%instance-length condition) 2) (- i 2))) + ((<= i (1+ sb-vm:instance-data-start)) + (make-unbound-marker)) + (when (eq (%instance-ref condition i) 'dx-object-type) + (return (%instance-ref condition (1+ i)))))) + +(defun make-condition (type &rest initargs) + "Make an instance of a condition object using the specified initargs." + ;; Note: While ANSI specifies no exceptional situations in this function, + ;; ALLOCATE-CONDITION will signal a type error if TYPE does not designate + ;; a condition class. This seems fair enough. + (declare (explicit-check)) + ;; FIXME: the compiler should have a way to make GETF operate on a &MORE arg + ;; so that the initargs are never listified. + (declare (dynamic-extent initargs)) + (multiple-value-bind (condition classoid) + (apply #'allocate-condition type initargs) + + ;; Set any class slots with initargs present in this call. + (dolist (cslot (condition-classoid-class-slots classoid)) + (loop for (key value) on initargs by #'cddr + when (memq key (condition-slot-initargs cslot)) + do (setf (car (condition-slot-cell cslot)) value) + (return) + finally + (multiple-value-bind (value found) + (find-slot-default-initarg classoid cslot) + (when found + (setf (car (condition-slot-cell cslot)) value))))) + + ;; Default any slots with non-constant defaults now. + (dolist (hslot (condition-classoid-hairy-slots classoid)) + (when (dolist (initarg (condition-slot-initargs hslot) t) + (unless (unbound-marker-p (getf initargs initarg sb-pcl:+slot-unbound+)) + (return nil))) + (setf (getf (condition-assigned-slots condition) + (condition-slot-name hslot)) + (find-slot-default classoid hslot)))) + + condition)) + +;;;; DEFINE-CONDITION + +(define-load-time-global *define-condition-hooks* nil) + +(defun %set-condition-report (name report) + (setf (condition-classoid-report (find-classoid name)) + report)) + +;;; Early definitions of slot accessor creators. +;;; +;;; Slot accessors must be generic functions, but ANSI does not seem +;;; to specify any of them, and we cannot support it before end of +;;; warm init. So we use ordinary functions inside SBCL, and switch to +;;; GFs only at the end of building. +(declaim (notinline install-condition-slot-reader + install-condition-slot-writer)) +(defun install-condition-slot-reader (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (set-closure-name + (lambda (condition) (condition-slot-value condition slot-name)) + t + `(condition-slot-reader ,name)))) +(defun install-condition-slot-writer (name condition slot-name) + (declare (ignore condition)) + (setf (fdefinition name) + (set-closure-name + (lambda (new-value condition) + (set-condition-slot-value condition new-value slot-name)) + t + `(condition-slot-writer ,name)))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun %%compiler-define-condition (name direct-supers layout readers writers) + (declare (notinline find-classoid)) + (preinform-compiler-about-class-type name nil) + (preinform-compiler-about-accessors 'condition readers writers) + (multiple-value-bind (class old-layout) + (insured-find-classoid name + #'condition-classoid-p + #'make-condition-classoid) + (setf (wrapper-classoid layout) class) + (setf (classoid-direct-superclasses class) + (mapcar #'find-classoid direct-supers)) + (cond ((not old-layout) + (register-layout layout)) + ((not *type-system-initialized*) + (setf (wrapper-classoid old-layout) class) + (setq layout old-layout) + (unless (eq (classoid-wrapper class) layout) + (register-layout layout))) + ((warn-if-altered-layout "current" + old-layout + "new" + (wrapper-length layout) + (wrapper-inherits layout) + (wrapper-depthoid layout) + (wrapper-bitmap layout)) + (register-layout layout :invalidate t)) + ((not (classoid-wrapper class)) + (register-layout layout))) + + (setf (find-classoid name) class) + + ;; Initialize CPL slot. + (setf (condition-classoid-cpl class) + (remove-if-not #'condition-classoid-p + (std-compute-class-precedence-list class))))) + +(defun %compiler-define-condition (name direct-supers layout readers writers) + (call-with-defining-class + 'condition name + (lambda () + (%%compiler-define-condition name direct-supers layout readers writers)))) +) ; EVAL-WHEN + +(defun %define-condition (name parent-types layout slots + direct-default-initargs all-readers all-writers + source-location &optional documentation) + (call-with-defining-class + 'condition name + (lambda () + (%%compiler-define-condition name parent-types layout all-readers all-writers) + (let ((classoid (find-classoid name))) + (when source-location + (setf (classoid-source-location classoid) source-location)) + (setf (condition-classoid-slots classoid) slots + (condition-classoid-direct-default-initargs classoid) direct-default-initargs + (documentation name 'type) documentation) + + (dolist (slot slots) + ;; Set up reader and writer functions. + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + (install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (install-condition-slot-writer writer name slot-name)))) + + ;; Compute effective slots and set up the class and hairy slots + ;; (subsets of the effective slots.) + (setf (condition-classoid-class-slots classoid) '() + (condition-classoid-hairy-slots classoid) '()) + (let ((eslots (compute-effective-slots classoid)) + (e-def-initargs + (reduce #'append + (mapcar #'condition-classoid-direct-default-initargs + (condition-classoid-cpl classoid))))) + (dolist (slot eslots) + (ecase (condition-slot-allocation slot) + (:class + (unless (condition-slot-cell slot) + (setf (condition-slot-cell slot) + (list (if (condition-slot-initform-p slot) + (let ((initfun (condition-slot-initfunction slot))) + (aver (functionp initfun)) + (funcall initfun)) + sb-pcl:+slot-unbound+)))) + (push slot (condition-classoid-class-slots classoid))) + ((:instance nil) + (setf (condition-slot-allocation slot) :instance) + ;; FIXME: isn't this "always hairy"? + (when (or (functionp (condition-slot-initfunction slot)) + (dolist (initarg (condition-slot-initargs slot) nil) + (when (functionp (third (assoc initarg e-def-initargs))) + (return t)))) + (push slot (condition-classoid-hairy-slots classoid))))))) + (when *type-system-initialized* + (dolist (fun *define-condition-hooks*) + (funcall fun classoid)))))) + name) + +(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) + &body options) + "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option* + Define NAME as a condition type. This new type inherits slots and its + report function from the specified PARENT-TYPEs. A slot spec is a list of: + (slot-name :reader :initarg {Option Value}* + + The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION + and :TYPE and the overall options :DEFAULT-INITARGS and + [type] :DOCUMENTATION are also allowed. + + The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either + a string or a two-argument lambda or function name. If a function, the + function is called with the condition and stream to report the condition. + If a string, the string is printed. + + Condition types are classes, but (as allowed by ANSI and not as described in + CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and + SLOT-VALUE may not be used on condition objects." + (check-designator name define-condition) + (let* ((parent-types (or parent-types '(condition))) + (layout (find-condition-layout name parent-types)) + (documentation nil) + (report nil) + (direct-default-initargs ())) + (collect ((slots) + (all-readers nil append) + (all-writers nil append)) + (dolist (spec slot-specs) + (with-current-source-form (spec) + (when (keywordp spec) + (warn "Keyword slot name indicates probable syntax error:~% ~S" + spec)) + (let* ((spec (if (consp spec) spec (list spec))) + (slot-name (first spec)) + (allocation :instance) + (initform-p nil) + documentation + initform) + (collect ((initargs) + (readers) + (writers)) + (do ((options (rest spec) (cddr options))) + ((null options)) + (unless (and (consp options) (consp (cdr options))) + (error "malformed condition slot spec:~% ~S." spec)) + (let ((arg (second options))) + (case (first options) + (:reader (readers arg)) + (:writer (writers arg)) + (:accessor + (readers arg) + (writers `(setf ,arg))) + (:initform + (when initform-p + (error "more than one :INITFORM in ~S" spec)) + (setq initform-p t) + (setq initform arg)) + (:initarg (initargs arg)) + (:allocation + (setq allocation arg)) + (:documentation + (when documentation + (error "more than one :DOCUMENTATION in ~S" spec)) + (unless (stringp arg) + (error "slot :DOCUMENTATION argument is not a string: ~S" + arg)) + (setq documentation arg)) + (:type + (check-slot-type-specifier + arg slot-name (cons 'define-condition name))) + (t + (error "unknown slot option:~% ~S" (first options)))))) + + (all-readers (readers)) + (all-writers (writers)) + (slots `(make-condition-slot + :name ',slot-name + :initargs ',(initargs) + :readers ',(readers) + :writers ',(writers) + :initform-p ',initform-p + :documentation ',documentation + :initform ,(when initform-p `',initform) + :initfunction ,(when initform-p + `#'(lambda () ,initform)) + :allocation ',allocation)))))) + + (dolist (option options) + (unless (consp option) + (error "bad option:~% ~S" option)) + (case (first option) + (:documentation (setq documentation (second option))) + (:report + (let ((arg (second option))) + (setq report + `#'(named-lambda (condition-report ,name) (condition stream) + (declare (type condition condition) + (type stream stream)) + ,@(if (stringp arg) + `((declare (ignore condition)) + (write-string ,arg stream)) + `((funcall #',arg condition stream))))))) + (:default-initargs + (doplist (initarg initform) (rest option) + (push ``(,',initarg ,',initform ,#'(lambda () ,initform)) + direct-default-initargs))) + (t + (error "unknown option: ~S" (first option))))) + + ;; Maybe kill docstring, but only under the cross-compiler. + #+(and (not sb-doc) sb-xc-host) (setq documentation nil) + `(progn + ,@(when *top-level-form-p* + ;; Avoid dumping uninitialized layouts, for sb-fasl::dump-layout + `((eval-when (:compile-toplevel) + (%compiler-define-condition ',name ',parent-types ,layout + ',(all-readers) ',(all-writers))))) + (%define-condition ',name + ',parent-types + ,(if *top-level-form-p* + layout + `(find-condition-layout ',name ',parent-types)) + (list ,@(slots)) + (list ,@direct-default-initargs) + ',(all-readers) + ',(all-writers) + (sb-c:source-location) + ,@(and documentation + `(,documentation))) + ;; This needs to be after %DEFINE-CONDITION in case :REPORT + ;; is a lambda referring to condition slot accessors: + ;; they're not proclaimed as functions before it has run if + ;; we're under EVAL or loaded as source. + (%set-condition-report ',name ,report) + ',name)))) + +;;; Compute the effective slots of CLASS, copying inherited slots and +;;; destructively modifying direct slots. +;;; +;;; FIXME: It'd be nice to explain why it's OK to destructively modify +;;; direct slots. Presumably it follows from the semantics of +;;; inheritance and redefinition of conditions, but finding the cite +;;; and documenting it here would be good. (Or, if this is not in fact +;;; ANSI-compliant, fixing it would also be good.:-) +(defun compute-effective-slots (class) + (collect ((res (copy-list (condition-classoid-slots class)))) + (dolist (sclass (cdr (condition-classoid-cpl class))) + (dolist (sslot (condition-classoid-slots sclass)) + (let ((found (find (condition-slot-name sslot) (res) + :key #'condition-slot-name))) + (cond (found + (setf (condition-slot-initargs found) + (union (condition-slot-initargs found) + (condition-slot-initargs sslot))) + (unless (condition-slot-initform-p found) + (setf (condition-slot-initform-p found) + (condition-slot-initform-p sslot)) + (setf (condition-slot-initform found) + (condition-slot-initform sslot)) + (setf (condition-slot-initfunction found) + (condition-slot-initfunction sslot))) + (unless (condition-slot-allocation found) + (setf (condition-slot-allocation found) + (condition-slot-allocation sslot)))) + (t + (res (copy-structure sslot))))))) + (res))) + + + +;;;; various CONDITIONs specified by ANSI + +(define-condition serious-condition (condition) ()) + +(define-condition error (serious-condition) ()) + +(define-condition warning (condition) ()) +(define-condition style-warning (warning) ()) + +(defun simple-condition-printer (condition stream) + (let ((control (simple-condition-format-control condition))) + (if control + (apply #'format stream + control + (simple-condition-format-arguments condition)) + (error "No format-control for ~S" condition)))) + +(define-condition simple-condition () + ((format-control :reader simple-condition-format-control + :initarg :format-control + :initform nil + :type format-control) + (format-arguments :reader simple-condition-format-arguments + :initarg :format-arguments + :initform nil + :type list)) + (:report simple-condition-printer)) + +(define-condition simple-warning (simple-condition warning) ()) + +(define-condition simple-error (simple-condition error) ()) + +(define-condition storage-condition (serious-condition) ()) + +(defun decode-type-error-context (context type) + (typecase context + (cons + (case (car context) + (:struct + (format nil "when setting slot ~s of structure ~s" + (cddr context) (cadr context))) + (t context))) + ((eql :aref) + (let (*print-circle*) + (format nil "when setting an element of (ARRAY ~s)" + type))) + ((eql :ftype) + "from the function type declaration.") + ((and symbol + (not null)) + (format nil "when binding ~s" context)) + (t + context))) + +(define-condition type-error (error) + ((datum :reader type-error-datum :initarg :datum) + (expected-type :reader type-error-expected-type :initarg :expected-type) + (context :initform nil :reader type-error-context :initarg :context)) + (:report report-general-type-error)) +(defun report-general-type-error (condition stream) + (let ((type (type-error-expected-type condition)) + (context (type-error-context condition))) + (if (eq context :multiple-values) + (format stream "~@" + (type-error-datum condition) + type) + (format stream "~@" + (type-error-datum condition) + type + (decode-type-error-context (type-error-context condition) + type))))) + +;;; not specified by ANSI, but too useful not to have around. +(define-condition simple-style-warning (simple-condition style-warning) ()) +(define-condition simple-type-error (simple-condition type-error) ()) + +(define-condition program-error (error) ()) +(define-condition parse-error (error) ()) +(define-condition control-error (error) ()) +(define-condition stream-error (error) + ((stream :reader stream-error-stream :initarg :stream))) + +(define-condition end-of-file (stream-error) () + (:report + (lambda (condition stream) + (format stream + "end of file on ~S" + (stream-error-stream condition))))) + +(define-condition closed-stream-error (stream-error) () + (:report + (lambda (condition stream) + (format stream "~S is closed" (stream-error-stream condition))))) + +(define-condition closed-saved-stream-error (closed-stream-error) () + (:report + (lambda (condition stream) + (format stream "~S was closed by SB-EXT:SAVE-LISP-AND-DIE" (stream-error-stream condition))))) + +(define-condition file-error (error) + ((pathname :reader file-error-pathname :initarg :pathname)) + (:report + (lambda (condition stream) + (format stream "error on file ~S" (file-error-pathname condition))))) + +(define-condition package-error (error) + ((package :reader package-error-package :initarg :package))) + +(define-condition cell-error (error) + ((name :reader cell-error-name :initarg :name))) + +(define-condition values-list-argument-error (type-error) + () + (:report + (lambda (condition stream) + (format stream "~@" + 'values-list (type-error-datum condition))))) + +(define-condition unbound-variable (cell-error) + ((not-yet-loaded :initform nil :reader not-yet-loaded :initarg :not-yet-loaded)) + (:report + (lambda (condition stream) + (format stream + "~@" + (cell-error-name condition) + (case (not-yet-loaded condition) + (:local + "~:@_It is a local variable ~ + not available at compile-time.") + (t + "")))))) + +(define-condition retry-unbound-variable + (simple-condition unbound-variable) ()) + +(define-condition undefined-function (cell-error) + ((not-yet-loaded :initform nil :reader not-yet-loaded :initarg :not-yet-loaded)) + (:report + (lambda (condition stream) + (let ((name (cell-error-name condition))) + (format stream + (if (and (symbolp name) (macro-function name)) + (sb-format:tokens "~@<~/sb-ext:print-symbol-with-prefix/ is a macro, ~ + not a function.~@:>") + (sb-format:tokens "~@")) + name + (case (not-yet-loaded condition) + (:local + (sb-format:tokens "~:@_It is a local function ~ + not available at compile-time.")) + ((t) (sb-format:tokens "~:@_It is defined earlier in the ~ + file but is not available at compile-time.")) + (t + ""))))))) + +(define-condition retry-undefined-function + (simple-condition undefined-function) ()) + +(define-condition special-form-function (undefined-function) () + (:report + (lambda (condition stream) + (format stream + "Cannot FUNCALL the SYMBOL-FUNCTION of special operator ~S." + (cell-error-name condition))))) + +(define-condition arithmetic-error (error) + ((operation :reader arithmetic-error-operation + :initarg :operation + :initform nil) + (operands :reader arithmetic-error-operands + :initarg :operands)) + (:report (lambda (condition stream) + (format stream + "arithmetic error ~S signalled" + (type-of condition)) + (when (arithmetic-error-operation condition) + (format stream + "~%Operation was (~S ~{~S~^ ~})." + (arithmetic-error-operation condition) + (arithmetic-error-operands condition)))))) + +(define-condition division-by-zero (arithmetic-error) ()) +(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition floating-point-underflow (arithmetic-error) ()) +(define-condition floating-point-inexact (arithmetic-error) ()) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) + +(define-condition print-not-readable (error) + ((object :reader print-not-readable-object :initarg :object)) + (:report + (lambda (condition stream) + (let ((obj (print-not-readable-object condition)) + (*print-array* nil)) + (format stream "~S cannot be printed readably." obj))))) + +(define-condition reader-error (parse-error stream-error) () + (:report (lambda (condition stream) + (%report-reader-error condition stream)))) + +;;; a READER-ERROR whose REPORTing is controlled by FORMAT-CONTROL and +;;; FORMAT-ARGS (the usual case for READER-ERRORs signalled from +;;; within SBCL itself) +;;; +;;; (Inheriting CL:SIMPLE-CONDITION here isn't quite consistent with +;;; the letter of the ANSI spec: this is not a condition signalled by +;;; SIGNAL when a format-control is supplied by the function's first +;;; argument. It seems to me (WHN) to be basically in the spirit of +;;; the spec, but if not, it'd be straightforward to do our own +;;; DEFINE-CONDITION SB-INT:SIMPLISTIC-CONDITION with +;;; FORMAT-CONTROL and FORMAT-ARGS slots, and use that condition in +;;; place of CL:SIMPLE-CONDITION here.) +(define-condition simple-reader-error (reader-error simple-condition) + () + (:report (lambda (condition stream) + (%report-reader-error condition stream :simple t)))) + +;;; base REPORTing of a READER-ERROR +;;; +;;; When SIMPLE, we expect and use SIMPLE-CONDITION-ish FORMAT-CONTROL +;;; and FORMAT-ARGS slots. +(defun %report-reader-error (condition stream &key simple position) + (let ((error-stream (stream-error-stream condition))) + (pprint-logical-block (stream nil) + (if simple + (apply #'format stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)) + (prin1 (class-name (class-of condition)) stream)) + (format stream "~2I~@[~:@_ ~:@_~:{~:(~A~): ~S~:^, ~:_~}~]~:@_ ~:@_Stream: ~S" + (stream-error-position-info error-stream position) + error-stream)))) + +;;;; special SBCL extension conditions + +;;; an error apparently caused by a bug in SBCL itself +;;; +;;; Note that we don't make any serious effort to use this condition +;;; for *all* errors in SBCL itself. E.g. type errors and array +;;; indexing errors can occur in functions called from SBCL code, and +;;; will just end up as ordinary TYPE-ERROR or invalid index error, +;;; because the signalling code has no good way to know that the +;;; underlying problem is a bug in SBCL. But in the fairly common case +;;; that the signalling code does know that it's found a bug in SBCL, +;;; this condition is appropriate, reusing boilerplate and helping +;;; users to recognize it as an SBCL bug. +(define-condition bug (simple-error) + () + (:report + (lambda (condition stream) + (format stream + "~@< ~? ~:@_~?~:>" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + "~@.~:@>" + '((fmakunbound 'compile)))))) + +(define-condition simple-storage-condition (storage-condition simple-condition) + ()) + +(define-condition sanitizer-error (simple-error) + ((value :reader sanitizer-error-value :initarg :value) + (address :reader sanitizer-error-address :initarg :address) + (size :reader sanitizer-error-size :initarg :size))) + +;;; a condition for use in stubs for operations which aren't supported +;;; on some platforms +;;; +;;; E.g. in sbcl-0.7.0.5, it might be appropriate to do something like +;;; #-(or freebsd linux) +;;; (defun load-foreign (&rest rest) +;;; (error 'unsupported-operator :name 'load-foreign)) +;;; #+(or freebsd linux) +;;; (defun load-foreign ... actual definition ...) +;;; By signalling a standard condition in this case, we make it +;;; possible for test code to distinguish between (1) intentionally +;;; unimplemented and (2) unintentionally just screwed up somehow. +;;; (Before this condition was defined, test code tried to deal with +;;; this by checking for FBOUNDP, but that didn't work reliably. In +;;; sbcl-0.7.0, a package screwup left the definition of +;;; LOAD-FOREIGN in the wrong package, so it was unFBOUNDP even on +;;; architectures where it was supposed to be supported, and the +;;; regression tests cheerfully passed because they assumed that +;;; unFBOUNDPness meant they were running on an system which didn't +;;; support the extension.) +(define-condition unsupported-operator (simple-error) ()) + +;;; (:ansi-cl :function remove) +;;; (:ansi-cl :section (a b c)) +;;; (:ansi-cl :glossary "similar") +;;; +;;; (:sbcl :node "...") +;;; (:sbcl :variable *ed-functions*) + +;;; +;;; FIXME: this is not the right place for this. +(defun print-reference (reference stream) + (ecase (car reference) + (:amop + (format stream "AMOP") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:readers "Readers for ~:(~A~) Metaobjects" + (substitute #\ #\- (symbol-name data))) + (:initialization + (format stream "Initialization of ~:(~A~) Metaobjects" + (substitute #\ #\- (symbol-name data)))) + (:generic-function (format stream "Generic Function ~S" data)) + (:function (format stream "Function ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data))))) + (:ansi-cl + (format stream "The ANSI Standard") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:function (format stream "Function ~S" data)) + (:special-operator (format stream "Special Operator ~S" data)) + (:macro (format stream "Macro ~S" data)) + (:section (format stream "Section ~{~D~^.~}" data)) + (:glossary (format stream "Glossary entry for ~S" data)) + (:type (format stream "Type ~S" data)) + (:system-class (format stream "System Class ~S" data)) + (:issue (format stream "writeup for Issue ~A" data))))) + (:sbcl + (format stream "The SBCL Manual") + (format stream ", ") + (destructuring-bind (type data) (cdr reference) + (ecase type + (:node (format stream "Node ~S" data)) + (:variable (format stream "Variable ~S" data)) + (:function (format stream "Function ~S" data))))) + ;; FIXME: other documents (e.g. CLIM, Franz documentation :-) + )) +(define-condition reference-condition () + ((references :initarg :references :reader reference-condition-references))) +(defvar *print-condition-references* t) + +(define-condition simple-reference-error (reference-condition simple-error) + ()) + +(define-condition simple-reference-warning (reference-condition simple-warning) + ()) + +(define-condition arguments-out-of-domain-error + (arithmetic-error reference-condition) + ()) + +;; per CLHS: "The consequences are unspecified if functions are ... +;; multiply defined in the same file." so we are within reason to do any +;; unspecified behavior at compile-time and/or time, but the compiler was +;; annoyingly mum about genuinely inadvertent duplicate macro definitions. +;; Redefinition is henceforth a style-warning, and for compatibility it does +;; not cause the ERRORP value from COMPILE-TIME to be T. +;; Nor do we cite section 3.2.2.3 as the governing prohibition. +(defun report-duplicate-definition (condition stream) + (format stream "~@" + (slot-value condition 'name))) + +(define-condition duplicate-definition (reference-condition warning) + ((name :initarg :name :reader duplicate-definition-name)) + (:report report-duplicate-definition) + (:default-initargs :references '((:ansi-cl :section (3 2 2 3))))) +;; To my thinking, DUPLICATE-DEFINITION should be the ancestor condition, +;; and not fatal. But changing the meaning of that concept would be a bad idea, +;; so instead there is a new condition for the softer variant, which does not +;; inherit from the former. +(define-condition same-file-redefinition-warning (style-warning) + ;; Slot readers aren't proper generic functions until CLOS is built, + ;; so this doesn't get a reader because you can't pick the same name, + ;; and it wouldn't do any good to pick a different name that nothing knows. + ((name :initarg :name)) + (:report report-duplicate-definition)) + +(define-condition constant-modified (reference-condition warning) + ((fun-name :initarg :fun-name :reader constant-modified-fun-name) + (values :initform nil :initarg :values :reader constant-modified-values)) + (:report (lambda (c s) + (format s "~@" + (constant-modified-fun-name c) + (constant-modified-values c)))) + (:default-initargs :references '((:ansi-cl :special-operator quote) + (:ansi-cl :section (3 7 1))))) + +(define-condition macro-arg-modified (constant-modified) + ((variable :initform nil :initarg :variable :reader macro-arg-modified-variable)) + (:report (lambda (c s) + (format s "~@" + (constant-modified-fun-name c) + (macro-arg-modified-variable c)))) + (:default-initargs :references nil)) + +(define-condition package-at-variance (reference-condition simple-warning) + () + (:default-initargs :references '((:ansi-cl :macro defpackage) + (:sbcl :variable *on-package-variance*)))) + +(define-condition package-at-variance-error (reference-condition simple-condition + package-error) + () + (:default-initargs :references '((:ansi-cl :macro defpackage)))) + +(define-condition defconstant-uneql (reference-condition error) + ((name :initarg :name :reader defconstant-uneql-name) + (old-value :initarg :old-value :reader defconstant-uneql-old-value) + (new-value :initarg :new-value :reader defconstant-uneql-new-value)) + (:report + (lambda (condition stream) + (format stream + "~@" + (defconstant-uneql-name condition) + (defconstant-uneql-old-value condition) + (defconstant-uneql-new-value condition)))) + (:default-initargs :references '((:ansi-cl :macro defconstant) + (:sbcl :node "Idiosyncrasies")))) + +(define-condition array-initial-element-mismatch + (reference-condition simple-warning) + () + (:default-initargs + :references '((:ansi-cl :function make-array) + (:ansi-cl :function upgraded-array-element-type)))) + +(define-condition initial-element-mismatch-style-warning + (array-initial-element-mismatch simple-style-warning) + ()) + +(define-condition type-warning (reference-condition simple-warning) + () + (:default-initargs :references '((:sbcl :node "Handling of Types")))) +(define-condition type-style-warning (reference-condition simple-style-warning) + () + (:default-initargs :references '((:sbcl :node "Handling of Types")))) +(define-condition slot-initform-type-style-warning (type-style-warning) ()) + +(define-condition local-argument-mismatch (reference-condition simple-warning) + () + (:default-initargs :references '((:ansi-cl :section (3 2 2 3))))) + +(define-condition format-args-mismatch (reference-condition) + () + (:default-initargs :references '((:ansi-cl :section (22 3 10 2))))) + +(define-condition format-too-few-args-warning + (format-args-mismatch simple-warning) + ()) +(define-condition format-too-many-args-warning + (format-args-mismatch simple-style-warning) + ()) + +(define-condition implicit-generic-function-warning (style-warning) + ((name :initarg :name :reader implicit-generic-function-name)) + (:report + (lambda (condition stream) + (format stream "~@" + (implicit-generic-function-name condition))))) + +(define-condition extension-failure (reference-condition simple-error) + ()) + +(define-condition structure-initarg-not-keyword + (reference-condition simple-style-warning) + () + (:default-initargs :references '((:ansi-cl :section (2 4 8 13))))) + +(define-condition package-lock-violation (package-error + reference-condition + simple-condition) + ((current-package :initform *package* + :reader package-lock-violation-in-package)) + (:report + (lambda (condition stream) + (let ((control (simple-condition-format-control condition)) + (error-package (package-name + (package-error-package condition))) + (current-package (package-name + (package-lock-violation-in-package condition)))) + (format stream "~@" + error-package + (when control + (list control (simple-condition-format-arguments condition))) + current-package)))) + ;; no :default-initargs -- reference-stuff provided by the + ;; signalling form in target-package.lisp + (:documentation + "Subtype of CL:PACKAGE-ERROR. A subtype of this error is signalled +when a package-lock is violated.")) + +(define-condition package-locked-error (package-lock-violation) () + (:documentation + "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is +signalled when an operation on a package violates a package lock.")) + +(define-condition symbol-package-locked-error (package-lock-violation) + ((symbol :initarg :symbol :reader package-locked-error-symbol)) + (:documentation + "Subtype of SB-EXT:PACKAGE-LOCK-VIOLATION. An error of this type is +signalled when an operation on a symbol violates a package lock. The +symbol that caused the violation is accessed by the function +SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL.")) + +(define-condition undefined-alien-error (cell-error) () + (:report + (lambda (condition stream) + (if (slot-boundp condition 'name) + (format stream "Undefined alien: ~S" (cell-error-name condition)) + (format stream "Undefined alien symbol."))))) + +(define-condition undefined-alien-variable-error (undefined-alien-error) () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Attempt to access an undefined alien variable.")))) + +(define-condition undefined-alien-function-error (undefined-alien-error) () + (:report + (lambda (condition stream) + (if (and (slot-boundp condition 'name) + (cell-error-name condition)) + (format stream "The alien function ~s is undefined." + (cell-error-name condition)) + (format stream "Attempt to call an undefined alien function."))))) + +(define-condition unknown-keyword-argument (program-error) + ((name :reader unknown-keyword-argument-name :initarg :name)) + (:report + (lambda (condition stream) + (format stream "Unknown &KEY argument: ~S" + (unknown-keyword-argument-name condition))))) + + +;;;; various other (not specified by ANSI) CONDITIONs +;;;; +;;;; These might logically belong in other files; they're here, after +;;;; setup of CONDITION machinery, only because that makes it easier to +;;;; get cold init to work. + +;;; OAOOM warning: see cross-condition.lisp +(define-condition encapsulated-condition (condition) + ((condition :initarg :condition :reader encapsulated-condition))) + +;;; KLUDGE: a condition for floating point errors when we can't or +;;; won't figure out what type they are. (In FreeBSD and OpenBSD we +;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably +;;; know how but the old code was broken by the conversion to POSIX +;;; signal handling and hasn't been fixed as of sbcl-0.6.7.) +;;; +;;; FIXME: Perhaps this should also be a base class for all +;;; floating point exceptions? +(define-condition floating-point-exception (arithmetic-error) + ((flags :initarg :traps + :initform nil + :reader floating-point-exception-traps)) + (:report (lambda (condition stream) + (format stream + "An arithmetic error ~S was signalled.~%" + (type-of condition)) + (let ((traps (floating-point-exception-traps condition))) + (if traps + (format stream + "Trapping conditions are: ~%~{ ~S~^~}~%" + traps) + (write-line + "No traps are enabled? How can this be?" + stream)))))) + +(define-condition invalid-array-index-error (type-error) + ((array :initarg :array :reader invalid-array-index-error-array) + (axis :initarg :axis :reader invalid-array-index-error-axis)) + (:report + (lambda (condition stream) + (let ((array (invalid-array-index-error-array condition))) + (format stream "Invalid index ~W for ~@[axis ~W of ~]~S, ~ + should be a non-negative integer below ~W." + (type-error-datum condition) + (when (> (array-rank array) 1) + (invalid-array-index-error-axis condition)) + (type-of array) + ;; Extract the bound from (INTEGER 0 (BOUND)) + (caaddr (type-error-expected-type condition))))))) + +(define-condition invalid-array-error (reference-condition type-error) () + (:report + (lambda (condition stream) + (let ((*print-array* nil)) + (format stream + "~@" + (type-error-expected-type condition) + (array-displacement (type-error-datum condition)))))) + (:default-initargs + :references + (list '(:ansi-cl :function adjust-array)))) + +(define-condition uninitialized-element-error (cell-error) () + (:report + (lambda (condition stream) + ;; NAME is a cons of the array and index + (destructuring-bind (array . index) (cell-error-name condition) + (declare (ignorable index)) + #+ubsan + (let* ((origin-pc + (ash (sb-vm::vector-extra-data + (if (simple-vector-p array) + array + (sb-vm::vector-extra-data array))) + -3)) ; XXX: ubsan magic + (origin-code (sb-di::code-header-from-pc (int-sap origin-pc)))) + (let ((*print-array* nil)) + (format stream "Element ~D of array ~_~S ~_was not assigned a value.~%Origin=~X" + index array (or origin-code origin-pc)))) + #-ubsan + ;; FOLD-INDEX-ADDRESSING could render INDEX wrong. There's no way to know. + (let ((*print-array* nil)) + (format stream "Uninitialized element accessed in array ~S" + array)))))) + + +;;; We signal this one for SEQUENCE operations, but INVALID-ARRAY-INDEX-ERROR +;;; for arrays. Might it be better to use the above condition for operations +;;; on SEQUENCEs that happen to be arrays? +(define-condition index-too-large-error (type-error) + ((sequence :initarg :sequence)) + (:report + (lambda (condition stream) + (let ((sequence (slot-value condition 'sequence)) + (index (type-error-datum condition))) + (if (vectorp sequence) + (format stream "Invalid index ~W for ~S ~@[with fill-pointer ~a~], ~ + should be a non-negative integer below ~W." + index + (type-of sequence) + (and (array-has-fill-pointer-p sequence) + (fill-pointer sequence)) + (length sequence)) + (format stream + "The index ~S is too large for a ~a of length ~s." + index + (if (listp sequence) + "list" + "sequence") + (length sequence))))))) + +(define-condition bounding-indices-bad-error (reference-condition type-error) + ((object :reader bounding-indices-bad-object :initarg :object)) + (:report + (lambda (condition stream) + (let* ((datum (type-error-datum condition)) + (start (car datum)) + (end (cdr datum)) + (object (bounding-indices-bad-object condition))) + (etypecase object + (sequence + (format stream + "The bounding indices ~S and ~S are bad ~ + for a sequence of length ~S." + start end (length object))) + (array + ;; from WITH-ARRAY-DATA + (format stream + "The START and END parameters ~S and ~S are ~ + bad for an array of total size ~S." + start end (array-total-size object))))))) + (:default-initargs + :references + (list '(:ansi-cl :glossary "bounding index designator") + '(:ansi-cl :issue "SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR")))) + +(define-condition nil-array-accessed-error (reference-condition type-error) + () + (:report (lambda (condition stream) + (declare (ignore condition)) + (format stream + "An attempt to access an array of element-type ~ + NIL was made. Congratulations!"))) + (:default-initargs + :references '((:ansi-cl :function upgraded-array-element-type) + (:ansi-cl :section (15 1 2 1)) + (:ansi-cl :section (15 1 2 2))))) + +(define-condition namestring-parse-error (parse-error) + ((complaint :reader namestring-parse-error-complaint :initarg :complaint) + (args :reader namestring-parse-error-args :initarg :args :initform nil) + (namestring :reader namestring-parse-error-namestring :initarg :namestring) + (offset :reader namestring-parse-error-offset :initarg :offset)) + (:report + (lambda (condition stream) + (format stream + "parse error in namestring: ~?~% ~A~% ~V@T^" + (namestring-parse-error-complaint condition) + (namestring-parse-error-args condition) + (namestring-parse-error-namestring condition) + (namestring-parse-error-offset condition))))) + +(define-condition pathname-unparse-error (file-error + simple-condition) + ((problem :reader pathname-unparse-error-problem :initarg :problem)) + (:report (lambda (condition stream) + (format stream "~@" + (file-error-pathname condition) + (pathname-unparse-error-problem condition) + (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))) + (:default-initargs + :problem (missing-arg))) + +(define-condition no-namestring-error (pathname-unparse-error + reference-condition) + () + (:default-initargs + :problem "does not have a namestring" + :references '((:ansi-cl :section (19 1 2))))) +(defun no-namestring-error + (pathname &optional format-control &rest format-arguments) + (error 'no-namestring-error + :pathname pathname + :format-control format-control :format-arguments format-arguments)) + +(define-condition no-native-namestring-error (pathname-unparse-error) + () + (:default-initargs + :problem "does not have a native namestring")) +(defun no-native-namestring-error + (pathname &optional format-control &rest format-arguments) + (error 'no-native-namestring-error + :pathname pathname + :format-control format-control :format-arguments format-arguments)) + +(define-condition simple-package-error (simple-condition package-error) ()) + +(define-condition package-does-not-exist (simple-package-error) ()) + +(define-condition simple-reader-package-error (simple-reader-error package-error) ()) +(define-condition reader-package-does-not-exist (simple-reader-package-error package-does-not-exist) ()) + +(define-condition reader-eof-error (end-of-file) + ((context :reader reader-eof-error-context :initarg :context)) + (:report + (lambda (condition stream) + (format stream + "unexpected end of file on ~S ~A" + (stream-error-stream condition) + (reader-eof-error-context condition))))) + +(define-condition reader-impossible-number-error (simple-reader-error) + ((error :reader reader-impossible-number-error-error :initarg :error)) + (:report + (lambda (condition stream) + (let ((error-stream (stream-error-stream condition))) + (format stream + "READER-ERROR ~@[at ~W ~]on ~S:~%~?~%Original error: ~A" + (sb-impl::file-position-or-nil-for-error error-stream) error-stream + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + (reader-impossible-number-error-error condition)))))) + +(define-condition standard-readtable-modified-error (reference-condition error) + ((operation :initarg :operation :reader standard-readtable-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard readtable." + (standard-readtable-modified-operation condition)))) + (:default-initargs :references `((:ansi-cl :section (2 1 1 2)) + (:ansi-cl :glossary "standard readtable")))) + +(define-condition standard-pprint-dispatch-table-modified-error + (reference-condition error) + ((operation :initarg :operation + :reader standard-pprint-dispatch-table-modified-operation)) + (:report (lambda (condition stream) + (format stream "~S would modify the standard pprint dispatch table." + (standard-pprint-dispatch-table-modified-operation + condition)))) + (:default-initargs + :references `((:ansi-cl :glossary "standard pprint dispatch table")))) + +(define-condition timeout (serious-condition) + ((seconds :initarg :seconds :initform nil :reader timeout-seconds)) + (:report (lambda (condition stream) + (format stream "Timeout occurred~@[ after ~A second~:P~]." + (timeout-seconds condition)))) + (:documentation + "Signaled when an operation does not complete within an allotted time budget.")) + +(define-condition io-timeout (stream-error timeout) + ((direction :reader io-timeout-direction :initarg :direction)) + (:report + (lambda (condition stream) + (declare (type stream stream)) + (format stream + "I/O timeout while doing ~(~A~) on ~S." + (io-timeout-direction condition) + (stream-error-stream condition))))) + +(define-condition deadline-timeout (timeout) + () + (:report (lambda (condition stream) + (format stream "A deadline was reached after ~A second~:P." + (timeout-seconds condition)))) + (:documentation + "Signaled when an operation in the context of a deadline takes +longer than permitted by the deadline.")) + +(define-condition declaration-type-conflict-error (reference-condition + simple-error) + () + (:default-initargs + :format-control + #.(macroexpand-1 ; stuff in a literal # + '(sb-format:tokens "Symbol ~/sb-ext:print-symbol-with-prefix/ cannot ~ + be both the name of a type and the name of a declaration")) + :references '((:ansi-cl :section (3 8 21))))) + +;;; Single stepping conditions + +(define-condition step-condition () + ((form :initarg :form :reader step-condition-form)) + (:documentation "Common base class of single-stepping conditions. +STEP-CONDITION-FORM holds a string representation of the form being +stepped.")) + +(setf (documentation 'step-condition-form 'function) + "Form associated with the STEP-CONDITION.") + +(define-condition step-form-condition (step-condition) + ((args :initarg :args :reader step-condition-args)) + (:report + (lambda (condition stream) + (let ((*print-circle* t) + (*print-pretty* t) + (*print-readably* nil)) + (format stream + "Evaluating call:~%~< ~@;~A~:>~%~ + ~:[With arguments:~%~{ ~S~%~}~;With unknown arguments~]~%" + (list (step-condition-form condition)) + (eq (step-condition-args condition) :unknown) + (step-condition-args condition))))) + (:documentation "Condition signalled by code compiled with +single-stepping information when about to execute a form. +STEP-CONDITION-FORM holds the form, STEP-CONDITION-PATHNAME holds the +pathname of the original file or NIL, and STEP-CONDITION-SOURCE-PATH +holds the source-path to the original form within that file or NIL. +Associated with this condition are always the restarts STEP-INTO, +STEP-NEXT, and STEP-CONTINUE.")) + +(define-condition step-result-condition (step-condition) + ((result :initarg :result :reader step-condition-result))) + +(setf (documentation 'step-condition-result 'function) + "Return values associated with STEP-VALUES-CONDITION as a list, +or the variable value associated with STEP-VARIABLE-CONDITION.") + +(define-condition step-values-condition (step-result-condition) + () + (:documentation "Condition signalled by code compiled with +single-stepping information after executing a form. +STEP-CONDITION-FORM holds the form, and STEP-CONDITION-RESULT holds +the values returned by the form as a list. No associated restarts.")) + +(define-condition step-finished-condition (step-condition) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream "Returning from STEP"))) + (:documentation "Condition signaled when STEP returns.")) + +;;; A knob for muffling warnings, mostly for use while loading files. +(defvar *muffled-warnings* 'uninteresting-redefinition + "A type that ought to specify a subtype of WARNING. Whenever a +warning is signaled, if the warning is of this type and is not +handled by any other handler, it will be muffled.") + +;;; Various STYLE-WARNING signaled in the system. +;; For the moment, we're only getting into the details for function +;; redefinitions, but other redefinitions could be done later +;; (e.g. methods). +(define-condition redefinition-warning (style-warning) + ((name + :initarg :name + :reader redefinition-warning-name) + (new-location + :initarg :new-location + :reader redefinition-warning-new-location))) + +(define-condition function-redefinition-warning (redefinition-warning) + ((new-function + :initarg :new-function + :reader function-redefinition-warning-new-function))) + +(define-condition redefinition-with-defun (function-redefinition-warning) + () + (:report (lambda (warning stream) + (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~ + in DEFUN" + (redefinition-warning-name warning))))) + +(define-condition redefinition-with-defmacro (function-redefinition-warning) + () + (:report (lambda (warning stream) + (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~ + in DEFMACRO" + (redefinition-warning-name warning))))) + +(define-condition redefinition-with-defgeneric (redefinition-warning) + () + (:report (lambda (warning stream) + (format stream "redefining ~/sb-ext:print-symbol-with-prefix/ ~ + in DEFGENERIC" + (redefinition-warning-name warning))))) + +(define-condition redefinition-with-defmethod (redefinition-warning) + ((qualifiers :initarg :qualifiers + :reader redefinition-with-defmethod-qualifiers) + (specializers :initarg :specializers + :reader redefinition-with-defmethod-specializers) + (new-location :initarg :new-location + :reader redefinition-with-defmethod-new-location) + (old-method :initarg :old-method + :reader redefinition-with-defmethod-old-method)) + (:report (lambda (warning stream) + (format stream "redefining ~S~{ ~S~} ~S in DEFMETHOD" + (redefinition-warning-name warning) + (redefinition-with-defmethod-qualifiers warning) + (redefinition-with-defmethod-specializers warning))))) + +;;;; Deciding which redefinitions are "interesting". + +(defun function-file-namestring (function) + (when (typep function 'interpreted-function) + (return-from function-file-namestring + #+sb-eval + (sb-c:definition-source-location-namestring + (sb-eval:interpreted-function-source-location function)) + #+sb-fasteval + (awhen (sb-interpreter:fun-source-location function) + (sb-c:definition-source-location-namestring it)))) + (let* ((fun (%fun-fun function)) + (code (fun-code-header fun)) + (debug-info (%code-debug-info code)) + (debug-source (when debug-info + (sb-c::debug-info-source debug-info))) + (namestring (when debug-source + (debug-source-namestring debug-source)))) + namestring)) + +(defun interesting-function-redefinition-warning-p (warning old) + (let ((new (function-redefinition-warning-new-function warning))) + (or + ;; compiled->interpreted is interesting. + (and (typep old 'compiled-function) + (typep new '(not compiled-function))) + ;; fin->regular is interesting except for interpreted->compiled. + (and (typep new '(not funcallable-instance)) + (typep old '(and funcallable-instance (not interpreted-function)))) + ;; different file or unknown location is interesting. + (let* ((old-namestring (function-file-namestring old)) + (new-namestring (function-file-namestring new))) + (and (or (not old-namestring) + (not new-namestring) + (not (string= old-namestring new-namestring)))))))) + +(setf (info :function :predicate-truth-constraint + 'uninteresting-ordinary-function-redefinition-p) 'warning) +(defun uninteresting-ordinary-function-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defun) + ;; Shared logic. + (let ((name (redefinition-warning-name warning))) + (not (interesting-function-redefinition-warning-p + warning (or (fdefinition name) (macro-function name))))))) + +(setf (info :function :predicate-truth-constraint + 'uninteresting-macro-redefinition-p) 'warning) +(defun uninteresting-macro-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defmacro) + ;; Shared logic. + (let ((name (redefinition-warning-name warning))) + (not (interesting-function-redefinition-warning-p + warning (or (macro-function name) (fdefinition name))))))) + +(setf (info :function :predicate-truth-constraint + 'uninteresting-generic-function-redefinition-p) 'warning) +(defun uninteresting-generic-function-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defgeneric) + ;; Can't use the shared logic above, since GF's don't get a "new" + ;; definition -- rather the FIN-FUNCTION is set. + (let* ((name (redefinition-warning-name warning)) + (old (fdefinition name)) + (old-location (when (typep old 'generic-function) + (sb-pcl::definition-source old))) + (old-namestring (when old-location + (sb-c:definition-source-location-namestring old-location))) + (new-location (redefinition-warning-new-location warning)) + (new-namestring (when new-location + (sb-c:definition-source-location-namestring new-location)))) + (and old-namestring + new-namestring + (string= old-namestring new-namestring))))) + +(setf (info :function :predicate-truth-constraint + 'uninteresting-method-redefinition-p) 'warning) +(defun uninteresting-method-redefinition-p (warning) + (and + (typep warning 'redefinition-with-defmethod) + ;; Can't use the shared logic above, since GF's don't get a "new" + ;; definition -- rather the FIN-FUNCTION is set. + (let* ((old-method (redefinition-with-defmethod-old-method warning)) + (old-location (sb-pcl::definition-source old-method)) + (old-namestring (when old-location + (sb-c:definition-source-location-namestring old-location))) + (new-location (redefinition-warning-new-location warning)) + (new-namestring (when new-location + (sb-c:definition-source-location-namestring new-location)))) + (and new-namestring + old-namestring + (string= new-namestring old-namestring))))) + +(deftype uninteresting-redefinition () + '(or (satisfies uninteresting-ordinary-function-redefinition-p) + (satisfies uninteresting-macro-redefinition-p) + (satisfies uninteresting-generic-function-redefinition-p) + (satisfies uninteresting-method-redefinition-p))) + +(define-condition redefinition-with-deftransform (redefinition-warning) + ((transform :initarg :transform + :reader redefinition-with-deftransform-transform)) + (:report (lambda (warning stream) + (format stream "Overwriting ~S" + (redefinition-with-deftransform-transform warning))))) + +;;; Various other STYLE-WARNINGS +(define-condition dubious-asterisks-around-variable-name + (style-warning simple-condition) + () + (:report (lambda (warning stream) + (format stream "~@?, even though the name follows~@ +the usual naming convention (names like *FOO*) for special variables" + (simple-condition-format-control warning) + (simple-condition-format-arguments warning))))) + +(define-condition asterisks-around-lexical-variable-name + (dubious-asterisks-around-variable-name) + ()) + +(define-condition asterisks-around-constant-variable-name + (dubious-asterisks-around-variable-name) + ()) + +(define-condition &optional-and-&key-in-lambda-list (simple-style-warning) ()) + +;; We call this UNDEFINED-ALIEN-STYLE-WARNING because there are some +;; subclasses of ERROR above having to do with undefined aliens. +(define-condition undefined-alien-style-warning (style-warning) + ((symbol :initarg :symbol :reader undefined-alien-symbol)) + (:report (lambda (warning stream) + (format stream "Undefined alien: ~S" + (undefined-alien-symbol warning))))) + +;;; Formerly this was guarded by "#+(or sb-eval sb-fasteval)", but +;;; why would someone build with no interpreter? And if they did, +;;; would they really care that one extra condition definition exists? +(define-condition lexical-environment-too-complex (style-warning) + ((form :initarg :form :reader lexical-environment-too-complex-form) + (lexenv :initarg :lexenv :reader lexical-environment-too-complex-lexenv)) + (:report (lambda (warning stream) + (format stream + "~@" + (lexical-environment-too-complex-form warning) + (lexical-environment-too-complex-lexenv warning))))) + +;; If the interpreter is in use (and the REPL is interpreted), +;; it's easy to accidentally make the macroexpand-hook an interpreted +;; function. So MACROEXPAND-1 is a little more careful, +;; and might signal this, instead of only EVAL being able to signal it. +(define-condition macroexpand-hook-type-error (type-error) + () + (:report (lambda (condition stream) + (format stream "The value of *MACROEXPAND-HOOK* is not a designator for a compiled function: ~S" + (type-error-datum condition))))) + +;; Although this has -ERROR- in the name, it's just a STYLE-WARNING. +(define-condition character-decoding-error-in-comment (style-warning) + ((stream :initarg :stream :reader decoding-error-in-comment-stream) + (position :initarg :position :reader decoding-error-in-comment-position)) + (:report (lambda (warning stream) + (format stream + "Character decoding error in a ~A-comment at ~ + position ~A reading source stream ~A, ~ + resyncing." + (decoding-error-in-comment-macro warning) + (decoding-error-in-comment-position warning) + (decoding-error-in-comment-stream warning))))) + +(define-condition character-decoding-error-in-macro-char-comment + (character-decoding-error-in-comment) + ((char :initform #\; :initarg :char + :reader character-decoding-error-in-macro-char-comment-char))) + +(define-condition character-decoding-error-in-dispatch-macro-char-comment + (character-decoding-error-in-comment) + ;; ANSI doesn't give a way for a reader function invoked by a + ;; dispatch macro character to determine which dispatch character + ;; was used, so if a user wants to signal one of these from a custom + ;; comment reader, he'll have to supply the :DISP-CHAR himself. + ((disp-char :initform #\# :initarg :disp-char + :reader character-decoding-error-in-macro-char-comment-disp-char) + (sub-char :initarg :sub-char + :reader character-decoding-error-in-macro-char-comment-sub-char))) + +(defun decoding-error-in-comment-macro (warning) + (etypecase warning + (character-decoding-error-in-macro-char-comment + (character-decoding-error-in-macro-char-comment-char warning)) + (character-decoding-error-in-dispatch-macro-char-comment + (format + nil "~C~C" + (character-decoding-error-in-macro-char-comment-disp-char warning) + (character-decoding-error-in-macro-char-comment-sub-char warning))))) + +(define-condition deprecated-eval-when-situations (style-warning) + ((situations :initarg :situations + :reader deprecated-eval-when-situations-situations)) + (:report (lambda (warning stream) + (format stream "using deprecated EVAL-WHEN situation names~{ ~S~}" + (deprecated-eval-when-situations-situations warning))))) + +(define-condition proclamation-mismatch (condition) + ((kind :initarg :kind :reader proclamation-mismatch-kind) + (description :initarg :description :reader proclamation-mismatch-description :initform nil) + (name :initarg :name :reader proclamation-mismatch-name) + (old :initarg :old :reader proclamation-mismatch-old) + (new :initarg :new :reader proclamation-mismatch-new)) + (:report + (lambda (condition stream) + (format stream + "~@" + (proclamation-mismatch-kind condition) + (proclamation-mismatch-description condition) + (proclamation-mismatch-name condition) + (proclamation-mismatch-new condition) + (proclamation-mismatch-old condition))))) + +(define-condition type-proclamation-mismatch (proclamation-mismatch) + () + (:default-initargs :kind 'type)) + +(define-condition type-proclamation-mismatch-warning (style-warning + type-proclamation-mismatch) + ()) + +(define-condition ftype-proclamation-mismatch (proclamation-mismatch) + () + (:default-initargs :kind 'ftype)) + +(define-condition ftype-proclamation-mismatch-warning (style-warning + ftype-proclamation-mismatch) + ()) + +(define-condition ftype-proclamation-mismatch-error (error + ftype-proclamation-mismatch) + () + (:default-initargs :kind 'ftype :description "known function")) + + +;;;; deprecation conditions + +(define-condition deprecation-condition (reference-condition) + ((namespace :initarg :namespace + :reader deprecation-condition-namespace) + (name :initarg :name + :reader deprecation-condition-name) + (replacements :initarg :replacements + :reader deprecation-condition-replacements) + (software :initarg :software + :reader deprecation-condition-software) + (version :initarg :version + :reader deprecation-condition-version) + (runtime-error :initarg :runtime-error + :reader deprecation-condition-runtime-error + :initform nil)) + (:default-initargs + :namespace (missing-arg) + :name (missing-arg) + :replacements (missing-arg) + :software (missing-arg) + :version (missing-arg) + :references '((:sbcl :node "Deprecation Conditions"))) + (:documentation + "Superclass for deprecation-related error and warning +conditions.")) + +(defmethod print-object ((condition deprecation-condition) stream) + (flet ((print-it (stream) + (print-deprecation-message + (deprecation-condition-namespace condition) + (deprecation-condition-name condition) + (deprecation-condition-software condition) + (deprecation-condition-version condition) + (deprecation-condition-replacements condition) + stream))) + (if *print-escape* + (print-unreadable-object (condition stream :type t) + (print-it stream)) + (print-it stream)))) + +(macrolet ((define-deprecation-warning + (name superclass check-runtime-error format-string + &optional documentation) + `(progn + (define-condition ,name (,superclass deprecation-condition) + () + ,@(when documentation + `((:documentation ,documentation)))) + + (defmethod print-object :after ((condition ,name) stream) + (when (and (not *print-escape*) + ,@(when check-runtime-error + `((deprecation-condition-runtime-error condition)))) + (format stream ,format-string + (deprecation-condition-software condition) + (deprecation-condition-name condition))))))) + + ;; These conditions must not occur in self-build! + (define-deprecation-warning early-deprecation-warning style-warning nil + "~%~@<~:@_In future~@[ ~A~] versions ~ + ~/sb-ext:print-symbol-with-prefix/ will signal a full warning ~ + at compile-time.~:@>" + "This warning is signaled when the use of a variable, +function, type, etc. in :EARLY deprecation is detected at +compile-time. The use will work at run-time with no warning or +error.") + + (define-deprecation-warning late-deprecation-warning warning t + "~%~@<~:@_In future~@[ ~A~] versions ~ + ~/sb-ext:print-symbol-with-prefix/ will signal a runtime ~ + error.~:@>" + "This warning is signaled when the use of a variable, +function, type, etc. in :LATE deprecation is detected at +compile-time. The use will work at run-time with no warning or +error.") + + (define-deprecation-warning final-deprecation-warning warning t + "~%~@<~:@_~*An error will be signaled at runtime for ~ + ~/sb-ext:print-symbol-with-prefix/.~:@>" + "This warning is signaled when the use of a variable, +function, type, etc. in :FINAL deprecation is detected at +compile-time. An error will be signaled at run-time.")) + +(define-condition deprecation-error (error deprecation-condition) + () + (:documentation + "This error is signaled at run-time when an attempt is made to use +a thing that is in :FINAL deprecation, i.e. call a function or access +a variable.")) + +;;;; restart definitions + +(define-condition abort-failure (control-error) () + (:report + "An ABORT restart was found that failed to transfer control dynamically.")) + +(defun abort (&optional condition) + "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if + none exists." + (invoke-restart (find-restart-or-control-error 'abort condition)) + ;; ABORT signals an error in case there was a restart named ABORT + ;; that did not transfer control dynamically. This could happen with + ;; RESTART-BIND. + (error 'abort-failure)) + +(defun muffle-warning (&optional condition) + "Transfer control to a restart named MUFFLE-WARNING, signalling a + CONTROL-ERROR if none exists." + (invoke-restart (find-restart-or-control-error 'muffle-warning condition))) + +(defun try-restart (name condition &rest arguments) + (let ((restart (find-restart name condition))) + (when restart + (apply #'invoke-restart restart arguments)))) + +(macrolet ((define-nil-returning-restart (name args doc) + `(defun ,name (,@args &optional condition) + ,doc + (try-restart ',name condition ,@args)))) + (define-nil-returning-restart continue () + "Transfer control to a restart named CONTINUE, or return NIL if none exists.") + (define-nil-returning-restart store-value (value) + "Transfer control and VALUE to a restart named STORE-VALUE, or +return NIL if none exists.") + (define-nil-returning-restart use-value (value) + "Transfer control and VALUE to a restart named USE-VALUE, or +return NIL if none exists.") + (define-nil-returning-restart print-unreadably () + "Transfer control to a restart named SB-EXT:PRINT-UNREADABLY, or +return NIL if none exists.")) + +;;; single-stepping restarts + +(macrolet ((def (name doc) + `(defun ,name (condition) + ,doc + (invoke-restart (find-restart-or-control-error ',name condition))))) + (def step-continue + "Transfers control to the STEP-CONTINUE restart associated with +the condition, continuing execution without stepping. Signals a +CONTROL-ERROR if the restart does not exist.") + (def step-next + "Transfers control to the STEP-NEXT restart associated with the +condition, executing the current form without stepping and continuing +stepping with the next form. Signals CONTROL-ERROR if the restart does +not exist.") + (def step-into + "Transfers control to the STEP-INTO restart associated with the +condition, stepping into the current form. Signals a CONTROL-ERROR if +the restart does not exist.")) + +;;; Compiler macro magic + +(define-condition compiler-macro-keyword-problem () + ((argument :initarg :argument :reader compiler-macro-keyword-argument)) + (:report (lambda (condition stream) + (format stream "~@" + (compiler-macro-keyword-argument condition))))) + +;; After (or if) we deem this the optimal name for this condition, +;; it should be exported from SB-EXT so that people can muffle it. +(define-condition sb-c:inlining-dependency-failure (simple-style-warning) ()) + + +(define-condition layout-invalid (type-error) + () + (:report + (lambda (condition stream) + (format stream + "~@" + (classoid-proper-name (type-error-expected-type condition)) + (type-error-datum condition))))) + +(define-condition case-failure (type-error) + ((name :reader case-failure-name :initarg :name) + ;; This is an internal symbol of SB-KERNEL, so I can't imagine that anyone + ;; expects an invariant that it be a list. + (possibilities :reader case-failure-possibilities :initarg :possibilities)) + (:report + (lambda (condition stream) + (let ((possibilities (case-failure-possibilities condition))) + (if (symbolp possibilities) + (report-general-type-error condition stream) + (let ((*print-escape* t)) + (format stream "~@<~S fell through ~S expression.~@[ ~ + ~:_Wanted one of (~/pprint-fill/).~]~:>" + (type-error-datum condition) + (case-failure-name condition) + (case-failure-possibilities condition)))))))) + +(define-condition compiled-program-error (program-error) + ((message :initarg :message :reader program-error-message) + (source :initarg :source :reader program-error-source)) + (:report (lambda (condition stream) + (format stream "Execution of a form compiled with errors.~%~ + Form:~% ~A~%~ + Compile-time error:~% ~A" + (program-error-source condition) + (program-error-message condition))))) + +(define-condition simple-control-error (simple-condition control-error) ()) + +(define-condition simple-file-error (simple-condition file-error) + ((message :initarg :message :reader simple-file-error-message :initform nil)) + (:report + (lambda (condition stream) + (format stream "~@<~?~@[: ~2I~_~A~]~@:>" + (simple-condition-format-control condition) + (simple-condition-format-arguments condition) + (simple-file-error-message condition))))) + +(defun %file-error (pathname &optional datum &rest arguments) + (typecase datum + (format-control (error 'simple-file-error :pathname pathname + :format-control datum + :format-arguments arguments)) + (t (apply #'error datum :pathname pathname arguments)))) + +(define-condition file-exists (simple-file-error) () + (:report + (lambda (condition stream) + (format stream "~@" + (file-error-pathname condition) + (simple-file-error-message condition))))) + +(define-condition file-does-not-exist (simple-file-error) () + (:report + (lambda (condition stream) + (format stream "~@" + (file-error-pathname condition) + (simple-file-error-message condition))))) + +(define-condition delete-file-error (simple-file-error) () + (:report + (lambda (condition stream) + (format stream "~@" + (file-error-pathname condition) + (simple-file-error-message condition))))) + +(define-condition simple-stream-error (simple-condition stream-error) ()) +(define-condition simple-parse-error (simple-condition parse-error) ()) + +(define-condition broken-pipe (simple-stream-error) ()) + +(define-condition character-coding-error (error) + ((external-format :initarg :external-format :reader character-coding-error-external-format))) +(define-condition character-encoding-error (character-coding-error) + ((code :initarg :code :reader character-encoding-error-code))) +(define-condition character-decoding-error (character-coding-error) + ((octets :initarg :octets :reader character-decoding-error-octets))) +(define-condition stream-encoding-error (stream-error character-encoding-error) + () + (:report + (lambda (c s) + (let ((stream (stream-error-stream c)) + (code (character-encoding-error-code c))) + (format s "~@<~S stream encoding error on ~S: ~2I~_~ + the character with code ~D cannot be encoded.~@:>" + (character-coding-error-external-format c) + stream + code))))) +(define-condition stream-decoding-error (stream-error character-decoding-error) + () + (:report + (lambda (c s) + (let ((stream (stream-error-stream c)) + (octets (character-decoding-error-octets c))) + (format s "~@<~S stream decoding error on ~S: ~2I~_~ + the octet sequence ~S cannot be decoded.~@:>" + (character-coding-error-external-format c) + stream + octets))))) + +(define-condition c-string-encoding-error (character-encoding-error) + () + (:report + (lambda (c s) + (format s "~@<~S c-string encoding error: ~2I~_~ + the character with code ~D cannot be encoded.~@:>" + (character-coding-error-external-format c) + (character-encoding-error-code c))))) + +(define-condition c-string-decoding-error (character-decoding-error) + () + (:report + (lambda (c s) + (format s "~@<~S c-string decoding error: ~2I~_~ + the octet sequence ~S cannot be decoded.~@:>" + (character-coding-error-external-format c) + (character-decoding-error-octets c))))) + +(define-condition control-stack-exhausted (storage-condition) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream + ;; no pretty-printing, because that would use a lot of stack. + "Control stack exhausted (no more space for function call frames). +This is probably due to heavily nested or infinitely recursive function +calls, or a tail call that SBCL cannot or has not optimized away. + +PROCEED WITH CAUTION.")))) + +(define-condition binding-stack-exhausted (storage-condition) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream + ;; no pretty-printing, because that would use a lot of stack. + "Binding stack exhausted. + +PROCEED WITH CAUTION.")))) + +(define-condition alien-stack-exhausted (storage-condition) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (format stream + ;; no pretty-printing, because that would use a lot of stack. + "Alien stack exhausted. + +PROCEED WITH CAUTION.")))) + +(define-condition heap-exhausted-error (storage-condition) + () + (:report + (lambda (condition stream) + (declare (ignore condition)) + (declare (special *heap-exhausted-error-available-bytes* + *heap-exhausted-error-requested-bytes*)) + ;; See comments in interr.lisp -- there is a method to this madness. + (if (and (boundp '*heap-exhausted-error-available-bytes*) + (boundp '*heap-exhausted-error-requested-bytes*)) + (format stream + ;; no pretty-printing, because that will use a lot of heap. + "Heap exhausted (no more space for allocation). +~D bytes available, ~D requested. + +PROCEED WITH CAUTION." + *heap-exhausted-error-available-bytes* + *heap-exhausted-error-requested-bytes*) + (format stream + "A ~S condition without bindings for heap statistics. (If +you did not expect to see this message, please report it." + 'heap-exhausted-error))))) + +(define-condition system-condition (condition) + ((address :initarg :address :reader system-condition-address :initform nil) + (context :initarg :context :reader system-condition-context :initform nil))) + +(define-condition memory-fault-error (system-condition error) () + (:report + (lambda (condition stream) + (format stream "Unhandled memory fault at #x~X." + (system-condition-address condition))))) + +(define-condition breakpoint-error (system-condition error) () + (:report + (lambda (condition stream) + (format stream "Unhandled breakpoint/trap at #x~X." + (system-condition-address condition))))) + +(define-condition interactive-interrupt (system-condition serious-condition) () + (:report + (lambda (condition stream) + (format stream "Interactive interrupt at #x~X." + (system-condition-address condition))))) + + +;;;; Condition reporting: + +;;; FIXME: ANSI's definition of DEFINE-CONDITION says +;;; Condition reporting is mediated through the PRINT-OBJECT method +;;; for the condition type in question, with *PRINT-ESCAPE* always +;;; being nil. Specifying (:REPORT REPORT-NAME) in the definition of +;;; a condition type C is equivalent to: +;;; (defmethod print-object ((x c) stream) +;;; (if *print-escape* (call-next-method) (report-name x stream))) +;;; The current code doesn't seem to quite match that. +(defmethod print-object ((object condition) stream) + (declare (notinline classoid-of)) ; to avoid can't inline warning. speed irrelevant here + (cond + ((not *print-escape*) + ;; KLUDGE: A comment from CMU CL here said + ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of + ;; superclasses in define-condition call! + (funcall (or (some #'condition-classoid-report + (condition-classoid-cpl (classoid-of object))) + (error "no REPORT? shouldn't happen!")) + object stream)) + ((and (typep object 'simple-condition) + (condition-slot-value object 'format-control)) + (print-unreadable-object (object stream :type t :identity t) + (write (simple-condition-format-control object) + :stream stream :lines 1))) + (t + (print-unreadable-object (object stream :type t :identity t))))) + + (defun assert-error (assertion &rest rest) (let* ((rest rest) (n-args-and-values (if (fixnump (car rest)) @@ -283,7 +2496,7 @@ (error 'case-failure :name 'etypecase :datum value - :expected-type `(or ,@keys) + :expected-type (if (symbolp keys) keys `(or ,@keys)) :possibilities keys)) (defun ecase-failure (value keys) diff -Nru sbcl-2.1.1/src/code/target-exception.lisp sbcl-2.1.11/src/code/target-exception.lisp --- sbcl-2.1.1/src/code/target-exception.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-exception.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -59,6 +59,8 @@ ;; Various (cons-name +exception-single-step+) (cons +exception-access-violation+ 'memory-fault-error) + #+x86-64 + (cons +exception-heap-corruption+ 'foreign-heap-corruption) (cons-name +exception-array-bounds-exceeded+) (cons-name +exception-breakpoint+) (cons-name +exception-datatype-misalignment+) @@ -112,6 +114,19 @@ (exception-record c) (exception-code c))))) +;;; Undocumented exception (STATUS_HEAP_CORRUPTION). Occurs when calling free() +;;; with a bad pointer and possibly other places. On 64-bit processes, +;;; frame-based handlers don't get a chance to handle this exception because the +;;; HeapSetInformation() option HeapEnableTerminationOnCorruption is enabled by +;;; default and cannot be disabled. For the sake of interactive development and +;;; error reporting, we special-case this exception in our vectored exception +;;; handler, otherwise the SBCL process would be abruptly terminated. +#+x86-64 +(define-condition foreign-heap-corruption (error) () + (:report + #.(format nil "A foreign heap corruption exception occurred. (Exception code: ~S)" + +exception-heap-corruption+))) + ;;; Actual exception handler. We hit something the runtime doesn't ;;; want to or know how to deal with (that is, not a sigtrap or gc wp ;;; violation), so it calls us here. diff -Nru sbcl-2.1.1/src/code/target-extensions.lisp sbcl-2.1.11/src/code/target-extensions.lisp --- sbcl-2.1.1/src/code/target-extensions.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-extensions.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -55,7 +55,8 @@ (define-load-time-global *init-hooks* nil "A list of function designators which are called in an unspecified order when a saved core image starts up, after the system itself has -been initialized. +been initialized, but before non-user threads such as the finalizer +thread have been started. Unused by SBCL itself: reserved for user and applications.") @@ -152,7 +153,7 @@ (type (integer 0 ,(1- array-dimension-limit)) ,pointer) (type (simple-array ,element-type (*)) ,string)) (flet ((push-char (char) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (when (= ,pointer ,size) (let ((old ,string)) (setf ,size (* 2 (+ ,size 2)) diff -Nru sbcl-2.1.1/src/code/target-format.lisp sbcl-2.1.11/src/code/target-format.lisp --- sbcl-2.1.1/src/code/target-format.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-format.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -134,6 +134,14 @@ (tokenize-control-string string)))) (interpret-directive-list stream tokens orig-args args))))) + +(!begin-collecting-cold-init-forms) +(define-load-time-global *format-directive-interpreters* nil) +(!cold-init-forms + (setq *format-directive-interpreters* (make-array 128 :initial-element nil))) +(declaim (type (simple-vector 128) + *format-directive-interpreters*)) + (defun interpret-directive-list (stream directives orig-args args) (loop (unless directives @@ -178,11 +186,9 @@ char))) (directive '.directive) ; expose this var to the lambda. it's easiest (directives (if lambda-list (car (last lambda-list)) (sb-xc:gensym "DIRECTIVES")))) - `(%svset ;; a cold-loadable form - *format-directive-interpreters* - ;; Using the host's char-upcase should be fine here. - ;; (Do we even need to use it? Why not just spell the source code as desired?) - ,(sb-xc:char-code (char-upcase char)) + `(!cold-init-forms + (setf + (aref *format-directive-interpreters* ,(char-code (char-upcase char))) (named-lambda ,defun-name (stream ,directive ,directives orig-args args) (declare (ignorable stream orig-args args)) ,@(if lambda-list @@ -192,7 +198,7 @@ (butlast lambda-list)) (values (progn ,@body) args))) `((declare (ignore ,directive ,directives)) - ,@body)))))) + ,@body))))))) (defmacro def-format-interpreter (char lambda-list &body body) (let ((directives (sb-xc:gensym "DIRECTIVES"))) @@ -688,15 +694,17 @@ (fmin (if (minusp k) 1 fdig))) (multiple-value-bind (fstr flen lpoint tpoint) (sb-impl::flonum-to-string num spaceleft fdig k fmin) - (when (and d (zerop d)) (setq tpoint nil)) + (when (eql fdig 0) (setq tpoint nil)) (when w (decf spaceleft flen) (when lpoint (if (or (> spaceleft 0) tpoint) (decf spaceleft) (setq lpoint nil))) - (when (and tpoint (<= spaceleft 0)) - (setq tpoint nil))) + (when tpoint + (if (<= spaceleft 0) + (setq tpoint nil) + (decf spaceleft)))) (cond ((and w (< spaceleft 0) ovf) ;;significand overflow (dotimes (i w) (write-char ovf stream))) @@ -707,6 +715,7 @@ (if atsign (write-char #\+ stream))) (when lpoint (write-char #\0 stream)) (write-string fstr stream) + (when tpoint (write-char #\0 stream)) (write-char (if marker marker (format-exponent-marker number)) @@ -1232,6 +1241,8 @@ (t (args param))))) (apply symbol stream (next-arg) colonp atsignp (args))))) +(!defun-from-collected-cold-init-forms !format-directives-init) + (push '("SB-FORMAT" def-format-directive def-complex-format-directive def-format-interpreter def-complex-format-interpreter diff -Nru sbcl-2.1.1/src/code/target-hash-table.lisp sbcl-2.1.11/src/code/target-hash-table.lisp --- sbcl-2.1.1/src/code/target-hash-table.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-hash-table.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -268,6 +268,7 @@ ;;; and at maximum load the table will have a load factor of 87.5% (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant kv-pairs-overhead-slots 3)) +(defconstant bad-next-value #xfefefefe) ;;; This constant is referenced via its name in cold load, so it needs to ;;; be evaluable in the host. (defconstant +min-hash-table-rehash-threshold+ #.(sb-xc:float 1/16 $1.0)) @@ -308,11 +309,10 @@ :initial-element +empty-ht-slot+))) (setf (kv-vector-high-water-mark v) 0) (setf (kv-vector-rehash-stamp v) 0) - ;; GC will see the vector as a hashing vector as soon as HASHING-SUBTYPE - ;; is set, so it needs to see a valid value in the 'supplement' slot. - ;; Neither 0 nor +empty-ht-slot+ is a valid value. + ;; If GC observes VECTOR-HASHING-FLAG, it needs to see a valid value + ;; in the 'supplement' slot. Neither 0 nor +empty-ht-slot+ is valid. (setf (kv-vector-supplement v) nil) - (set-header-data v sb-vm:vector-hashing-flag) + (logior-array-flags v sb-vm:vector-hashing-flag) v)) (defun install-hash-table-lock (table) @@ -488,23 +488,38 @@ (scaled-size (truncate (/ (float size) rehash-threshold))) (bucket-count (power-of-two-ceiling (max scaled-size +min-hash-table-size+))) - (index-vector (make-array bucket-count - :element-type 'hash-table-index - :initial-element 0)) (weakp (logtest flags hash-table-weak-flag)) - (kv-vector (%alloc-kv-pairs size)) + ;; Non-weak tables created with no options other than :TEST + ;; are allocated at 0 size. Weak tables are complicated enough, + ;; so just do their usual thing. + (defaultp (and (not weakp) (= size +min-hash-table-size+))) + (index-vector + (if defaultp + #.(sb-xc:make-array 2 :element-type '(unsigned-byte 32) + :initial-element 0) + (make-array bucket-count :element-type 'hash-table-index + :initial-element 0))) + (kv-vector (if defaultp #(0 0 nil) (%alloc-kv-pairs size))) ;; Needs to be the half the length of the KV vector to link ;; KV entries - mapped to indices at 2i and 2i+1 - ;; together. ;; We don't need this to be initially 0-filled, so don't specify ;; an initial element (in case we ever meaningfully distinguish ;; between don't-care and 0-fill) - (next-vector (make-array (1+ size) :element-type 'hash-table-index)) + (next-vector (if defaultp + #.(sb-xc:make-array 0 :element-type '(unsigned-byte 32)) + (make-array (1+ size) :element-type 'hash-table-index + ;; For testing, preload huge values for all 'next' elements + ;; so that we generate an error if any is inadvertently read + ;; above the high-water-mark for the k/v vector. + #+sb-devel :initial-element #+sb-devel bad-next-value))) (table-kind (ht-flags-kind flags)) (userfunp (logtest flags hash-table-userfun-flag)) ;; same here - don't care about initial contents (hash-vector (when (or userfunp (>= table-kind 2)) - (make-array (1+ size) :element-type 'hash-table-index))) + (if defaultp + #.(sb-xc:make-array 1 :element-type '(unsigned-byte 32)) + (make-array (1+ size) :element-type 'hash-table-index)))) ((getter setter remover) (if weakp (values #'gethash/weak #'puthash/weak #'remhash/weak) @@ -521,13 +536,19 @@ ;; at the table. Weak hashing vectors need the table. ;; As a special-case, non-weak tables with EQL hashing put T in this slot. ;; GC can't get the table kind since it doesn't have access to the table. - (setf (kv-vector-supplement kv-vector) - (if weakp - table - (or hash-vector (= table-kind hash-table-kind-eql)))) - (when weakp - (set-header-data kv-vector (logior sb-vm:vector-hashing-flag - sb-vm:vector-weak-flag))) + (cond (defaultp + ;; Stash the desired size for the first time the vectors are grown. + (setf (hash-table-cache table) size + ;; Cause the overflow logic to be invoked on the first insert. + (hash-table-next-free-kv table) 0)) + (t + (setf (kv-vector-supplement kv-vector) + (if weakp + table + (or hash-vector (= table-kind hash-table-kind-eql)))) + (when weakp + (logior-array-flags kv-vector (logior sb-vm:vector-hashing-flag + sb-vm:vector-weak-flag))))) (when (logtest flags hash-table-synchronized-flag) (install-hash-table-lock table)) table)) @@ -571,7 +592,8 @@ "Return a size that can be used with MAKE-HASH-TABLE to create a hash table that can hold however many entries HASH-TABLE can hold without having to be grown." - (hash-table-pairs-capacity (hash-table-pairs hash-table))) + (let ((n (hash-table-pairs-capacity (hash-table-pairs hash-table)))) + (if (= n 0) +min-hash-table-size+ n))) (setf (documentation 'hash-table-test 'function) "Return the test HASH-TABLE was created with.") @@ -639,7 +661,9 @@ :element-type 'hash-table-index :initial-element 0)) (new-kv-vector (%alloc-kv-pairs new-size)) - (new-next-vector (make-array (1+ new-size) :element-type 'hash-table-index)) + (new-next-vector (make-array (1+ new-size) :element-type 'hash-table-index + ;; for robustness testing, as explained in %MAKE-HASH-TABLE + #+sb-devel :initial-element #+sb-devel bad-next-value)) (new-hash-vector (when old-hash-vector (make-array (1+ new-size) :element-type 'hash-table-index)))) @@ -714,7 +738,7 @@ ;; Set address-sensitivity BEFORE depending on the bits. ;; Precise GC platforms can move any key except the ones which ;; are explicitly pinned. - (set-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag) (push-in-chain (pointer-hash->bucket (pointer-hash key) mask))))))) ((= (ht-flags-kind (hash-table-flags table)) hash-table-kind-eql) ;; There's a very tricky issue here with using EQL-HASH - you can't just @@ -745,7 +769,7 @@ (pin-object key) (multiple-value-bind (hash address-based) (eql-hash-no-memoize key) (when address-based - (set-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (mask-hash (prefuzz-hash hash) mask))))))))) (t (do ((i hwm (1- i))) ((zerop i)) @@ -755,7 +779,7 @@ (setf (aref next-vector i) next-free next-free i)) (t (when (sb-vm:is-lisp-pointer (get-lisp-obj-address key)) - (set-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (pointer-hash->bucket (pointer-hash key) mask)))))))) ;; This is identical to the calculation of next-free-kv in INSERT-AT. (cond ((/= next-free 0) next-free) @@ -791,7 +815,7 @@ ;; to the hashing vectors, since at most one thread can win this CAS. (when (eq (cas (svref kv-vector rehash-stamp-elt) epoch rehashing-state) epoch) ;; Remove address-sensitivity, preserving the other flags. - (unset-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (reset-array-flags kv-vector sb-vm:vector-addr-hashing-flag) ;; Rehash in place. For the duration of the rehash, readers who otherwise ;; might have seen intact chains (by which to find address-insensitive keys) ;; can't. No big deal. If we were willing to cons new vectors, we could @@ -801,7 +825,7 @@ (mask (1- (length index-vector))) (hwm (kv-vector-high-water-mark kv-vector)) (result 0)) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (cond (hash-vector (do ((i hwm (1- i))) ((zerop i)) @@ -813,7 +837,7 @@ (cond ((/= (aref hash-vector i) +magic-hash-vector-value+) (push-in-chain (mask-hash (aref hash-vector i) mask))) (t - (set-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag) (push-in-chain (pointer-hash->bucket (pointer-hash pair-key) mask)))) (when (eq pair-key key) (setq result key-index)))))) @@ -826,7 +850,7 @@ (pin-object pair-key) (multiple-value-bind (hash address-based) (eql-hash-no-memoize pair-key) (when address-based - (set-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (mask-hash (prefuzz-hash hash) mask))) (when (eq pair-key key) (setq result key-index))))))) (t @@ -836,7 +860,7 @@ (with-pair (pair-key) (unless (empty-ht-slot-p pair-key) (when (sb-vm:is-lisp-pointer (get-lisp-obj-address pair-key)) - (set-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) (push-in-chain (pointer-hash->bucket (pointer-hash pair-key) mask)) (when (eq pair-key key) (setq result key-index))))))) @@ -850,6 +874,24 @@ ;;; made non-weak so that we don't have to deal with GC-related shenanigans. (defun grow-hash-table (table) (declare (type hash-table table)) + (when (= (hash-table-%count table) 0) ; special case for new table + (let* ((size (shiftf (hash-table-cache table) 0)) + (scaled-size (truncate (/ (float size) (hash-table-rehash-threshold table)))) + (bucket-count (power-of-two-ceiling (max scaled-size +min-hash-table-size+))) + (index-vector (make-array bucket-count :element-type 'hash-table-index + :initial-element 0)) + (kv-vector (%alloc-kv-pairs size)) + (next-vector (make-array (1+ size) :element-type 'hash-table-index + #+sb-devel :initial-element #+sb-devel bad-next-value)) + (hash-vector (when (hash-table-hash-vector table) + (make-array (1+ size) :element-type 'hash-table-index)))) + (setf (kv-vector-supplement kv-vector) (or hash-vector + (eq (hash-table-test table) 'eql)) + (hash-table-pairs table) kv-vector + (hash-table-index-vector table) index-vector + (hash-table-next-vector table) next-vector + (hash-table-hash-vector table) hash-vector) + (return-from grow-hash-table 1))) (binding* (((new-kv-vector new-next-vector new-hash-vector new-index-vector) (hash-table-new-vectors table)) (old-kv-vector (hash-table-pairs table)) @@ -881,7 +923,7 @@ ;; for rehash (it's going to be zeroed out). ;; Clearing the weakness causes all entries to stay alive. ;; Furthermore, clearing both makes the trailing metadata ignorable. - (set-header-data old-kv-vector sb-vm:vector-hashing-flag) + (assign-vector-flags old-kv-vector sb-vm:vector-hashing-flag) (setf (kv-vector-supplement old-kv-vector) nil) ;; The high-water-mark remains unchanged. @@ -918,7 +960,7 @@ ;; Now that the table points to the right hash-vector ;; we can set the vector's backpointer and turn it weak. (setf (kv-vector-supplement new-kv-vector) table) - (set-header-bits new-kv-vector sb-vm:vector-weak-flag)) + (logior-array-flags new-kv-vector sb-vm:vector-weak-flag)) ;; Zero-fill the old kv-vector. For weak hash-tables this removes the ;; strong references to each k/v. For non-weak vectors there is no technical @@ -1316,7 +1358,7 @@ (aver (eql (cas (svref kv-vector rehash-stamp-elt) initial-stamp (1+ initial-stamp)) initial-stamp)) ;; Remove weakness and address-sensitivity. - (set-header-data kv-vector sb-vm:vector-hashing-flag) + (assign-vector-flags kv-vector sb-vm:vector-hashing-flag) ;; We don't need to zero-fill the NEXT vector, just the INDEX vector. ;; Unless a key slot can be reached by a chain starting from the index ;; vector or the 'next' of a previous chain element, we don't read either @@ -1331,7 +1373,7 @@ ;; so clear the list of GC-smashed cells. (setf (hash-table-smashed-cells hash-table) nil) ;; Re-enable weakness - (set-header-bits kv-vector sb-vm:vector-weak-flag) + (logior-array-flags kv-vector sb-vm:vector-weak-flag) (done-rehashing kv-vector initial-stamp)) ;; One more try gives the definitive answer even if the hashes are ;; obsolete again. KEY's hash can't have changed, and there @@ -1392,7 +1434,7 @@ ;;; key and hash-table-test whenever some thread is rehashing. If hash-based ;;; lookup uses EQ as the comparator for KEY, then linear search does too. (defun hash-table-lsearch (hash-table eq-test key hash default) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (declare (type (and fixnum unsigned-byte) hash)) (atomic-incf (hash-table-n-lsearch hash-table)) (let* ((kv-vector (hash-table-pairs hash-table)) @@ -1510,8 +1552,8 @@ ;;; because insertion can not co-occur with any other operation, ;;; unlike GETHASH which we allow to execute in multiple threads. (defmacro define-ht-setter (name std-fn) - `(named-lambda ,name (key table value &aux (hash-table (truly-the hash-table table)) - (kv-vector (hash-table-pairs hash-table))) + `(defun ,name (key table value &aux (hash-table (truly-the hash-table table)) + (kv-vector (hash-table-pairs hash-table))) (declare (optimize speed (sb-c:verify-arg-count 0))) (block done (let ((cache (hash-table-cache hash-table))) @@ -1585,78 +1627,77 @@ (insert-at (hash-table-next-free-kv hash-table) hash-table key hash address-based-p value)))))) -(defun get-puthash-definitions () - (flet ((insert-at (index hash-table key hash address-based-p value) - (declare (optimize speed) (type index/2 index)) - (when (zerop index) - (setq index (grow-hash-table hash-table)) - ;; Growing the table can not make the key become found when it was not - ;; found before, so we can just proceed with insertion. - (aver (not (zerop index)))) - ;; Grab the vectors AFTER possibly growing the table - (let ((kv-vector (hash-table-pairs hash-table)) - (next-vector (hash-table-next-vector hash-table))) - (setf (hash-table-next-free-kv hash-table) - (let ((hwm (kv-vector-high-water-mark kv-vector)) - (cap (hash-table-pairs-capacity kv-vector))) - (cond ((> index hwm) ; raise the high-water-mark - (setf (kv-vector-high-water-mark kv-vector) index) - ;; CPU must not buffer storing the new HWM versus the - ;; stores of the K+V since they wouldn't be seen. - (sb-thread:barrier (:write)) - (cond ((= index cap) 0) - (t (1+ index)))) - (t ; don't raise - (let ((next (aref next-vector index))) - (cond ((/= next 0) next) - ((= hwm cap) 0) - (t (1+ hwm)))))))) - - ;; We've potentially depended on the bits of the address of KEY - ;; before informing GC that we've done so, but the key is pinned, - ;; so as long as the table informs GC that it has the dependency - ;; by the time the key is free to move, all is well. - (when address-based-p - (set-header-bits kv-vector sb-vm:vector-addr-hashing-flag)) - - ;; Store the hash unless an EQ table. Because the key is pinned, it is - ;; OK that GC would not have seen +magic-hash-vector-value+ for this - ;; key if applicable. - (awhen (hash-table-hash-vector hash-table) - (setf (aref it index) - (if address-based-p +magic-hash-vector-value+ hash))) - - ;; Store the pair - (let ((i (* 2 index))) - (setf (aref kv-vector i) key (aref kv-vector (1+ i)) value)) - ;; Push this slot onto the front of the chain for its bucket. - (let* ((index-vector (hash-table-index-vector hash-table)) - (bucket (mask-hash hash (1- (length index-vector))))) - (setf (aref next-vector index) (aref index-vector bucket) - (aref index-vector bucket) index))) - (incf (hash-table-%count hash-table)) - value)) - - (values (named-lambda puthash/weak (key hash-table value) - (declare (type hash-table hash-table) (optimize speed)) - (with-weak-hash-table-entry - (declare (ignore predecessor)) - (cond ((= physical-index 0) - ;; There are two kinds of freelists. Prefer a smashed cell - ;; so that we might shorten the chain it belonged to. - (insert-at (or (hash-table-next-smashed-kv hash-table) - (hash-table-next-free-kv hash-table)) - hash-table key hash address-sensitive-p value)) - ((or (empty-ht-slot-p (cas (svref kv-vector (1+ physical-index)) - probed-value value)) - (neq (svref kv-vector physical-index) probed-key)) - (signal-corrupt-hash-table hash-table)) - (t value)))) - (define-ht-setter puthash/eq eq) - (define-ht-setter puthash/eql eql) - (define-ht-setter puthash/equal equal) - (define-ht-setter puthash/equalp equalp) - (define-ht-setter puthash/any nil)))) +(flet ((insert-at (index hash-table key hash address-based-p value) + (declare (optimize speed) (type index/2 index)) + (when (zerop index) + (setq index (grow-hash-table hash-table)) + ;; Growing the table can not make the key become found when it was not + ;; found before, so we can just proceed with insertion. + (aver (not (zerop index)))) + ;; Grab the vectors AFTER possibly growing the table + (let ((kv-vector (hash-table-pairs hash-table)) + (next-vector (hash-table-next-vector hash-table))) + (setf (hash-table-next-free-kv hash-table) + (let ((hwm (kv-vector-high-water-mark kv-vector)) + (cap (hash-table-pairs-capacity kv-vector))) + (cond ((> index hwm) ; raise the high-water-mark + (setf (kv-vector-high-water-mark kv-vector) index) + ;; CPU must not buffer storing the new HWM versus the + ;; stores of the K+V since they wouldn't be seen. + (sb-thread:barrier (:write)) + (cond ((= index cap) 0) + (t (1+ index)))) + (t ; don't raise + (let ((next (aref next-vector index))) + (cond ((/= next 0) next) + ((= hwm cap) 0) + (t (1+ hwm)))))))) + + ;; We've potentially depended on the bits of the address of KEY + ;; before informing GC that we've done so, but the key is pinned, + ;; so as long as the table informs GC that it has the dependency + ;; by the time the key is free to move, all is well. + (when address-based-p + (logior-array-flags kv-vector sb-vm:vector-addr-hashing-flag)) + + ;; Store the hash unless an EQ table. Because the key is pinned, it is + ;; OK that GC would not have seen +magic-hash-vector-value+ for this + ;; key if applicable. + (awhen (hash-table-hash-vector hash-table) + (setf (aref it index) + (if address-based-p +magic-hash-vector-value+ hash))) + + ;; Store the pair + (let ((i (* 2 index))) + (setf (aref kv-vector i) key (aref kv-vector (1+ i)) value)) + ;; Push this slot onto the front of the chain for its bucket. + (let* ((index-vector (hash-table-index-vector hash-table)) + (bucket (mask-hash hash (1- (length index-vector))))) + (setf (aref next-vector index) (aref index-vector bucket) + (aref index-vector bucket) index))) + (incf (hash-table-%count hash-table)) + value)) + + (defun puthash/weak (key hash-table value) + (declare (type hash-table hash-table) (optimize speed)) + (with-weak-hash-table-entry + (declare (ignore predecessor)) + (cond ((= physical-index 0) + ;; There are two kinds of freelists. Prefer a smashed cell + ;; so that we might shorten the chain it belonged to. + (insert-at (or (hash-table-next-smashed-kv hash-table) + (hash-table-next-free-kv hash-table)) + hash-table key hash address-sensitive-p value)) + ((or (empty-ht-slot-p (cas (svref kv-vector (1+ physical-index)) + probed-value value)) + (neq (svref kv-vector physical-index) probed-key)) + (signal-corrupt-hash-table hash-table)) + (t value)))) + (define-ht-setter puthash/eq eq) + (define-ht-setter puthash/eql eql) + (define-ht-setter puthash/equal equal) + (define-ht-setter puthash/equalp equalp) + (define-ht-setter puthash/any nil)) (defun %puthash (key hash-table value) (declare (type hash-table hash-table)) @@ -1669,7 +1710,7 @@ (funcall (hash-table-puthash-impl hash-table) key hash-table value)) (defmacro define-remhash (name std-fn) - `(named-lambda ,name (key table &aux (hash-table (truly-the hash-table table)) + `(defun ,name (key table &aux (hash-table (truly-the hash-table table)) (kv-vector (hash-table-pairs hash-table))) (declare (optimize speed (sb-c:verify-arg-count 0))) ;; The cache provides no benefit to REMHASH. A hit would just mean there is work @@ -1739,93 +1780,77 @@ (decf (hash-table-%count hash-table)) t))))) -(defun get-remhash-definitions () - (labels ((clear-slot (index hash-table kv-vector next-vector) - (declare (type index/2 index)) - ;; Mark slot as empty. - (let ((physindex (* 2 index))) - (setf (aref kv-vector physindex) +empty-ht-slot+ - (aref kv-vector (1+ physindex)) +empty-ht-slot+)) - ;; Push KV slot onto free chain. - ;; Possible optimization: if we linked the free chain through - ;; the 'value' half of a pair, we could avoid rebuilding the - ;; free chain in %REHASH because rehashing won't affect it. - ;; (Maybe it already doesn't?) - (setf (aref next-vector index) (hash-table-next-free-kv hash-table) - (hash-table-next-free-kv hash-table) index) - ;; On parallel accesses this may turn out to be a - ;; type-error, so don't turn down the safety! - (decf (hash-table-%count hash-table)) - t) - (remove-from-bucket (key bucket hash-table initial-stamp - &aux (kv-vector (hash-table-pairs hash-table))) - ;; Remove KEY from BUCKET which is based on the current address - ;; of key after pinning. When the key was not found initially, - ;; the "problem" so to speak was that the bucket that was searched - ;; did not hold the key, and not that search was done on the wrong - ;; bucket. Rehashing will place the key into the expected bucket. - ;; - ;; The current stamp must be the same as initial-stamp, because - ;; REMHASH is disallowed concurrently with any other operation, - ;; and the 'rehash' bit can't be cleared except by rehashing - ;; as part of such operation. - (unless (eq (kv-vector-rehash-stamp kv-vector) initial-stamp) +(labels ((clear-slot (index hash-table kv-vector next-vector) + (declare (type index/2 index)) + ;; Mark slot as empty. + (let ((physindex (* 2 index))) + (setf (aref kv-vector physindex) +empty-ht-slot+ + (aref kv-vector (1+ physindex)) +empty-ht-slot+)) + ;; Push KV slot onto free chain. + ;; Possible optimization: if we linked the free chain through + ;; the 'value' half of a pair, we could avoid rebuilding the + ;; free chain in %REHASH because rehashing won't affect it. + ;; (Maybe it already doesn't?) + (setf (aref next-vector index) (hash-table-next-free-kv hash-table) + (hash-table-next-free-kv hash-table) index) + ;; On parallel accesses this may turn out to be a + ;; type-error, so don't turn down the safety! + (decf (hash-table-%count hash-table)) + t) + (remove-from-bucket (key bucket hash-table initial-stamp + &aux (kv-vector (hash-table-pairs hash-table))) + ;; Remove KEY from BUCKET which is based on the current address + ;; of key after pinning. When the key was not found initially, + ;; the "problem" so to speak was that the bucket that was searched + ;; did not hold the key, and not that search was done on the wrong + ;; bucket. Rehashing will place the key into the expected bucket. + ;; + ;; The current stamp must be the same as initial-stamp, because + ;; REMHASH is disallowed concurrently with any other operation, + ;; and the 'rehash' bit can't be cleared except by rehashing + ;; as part of such operation. + (unless (eq (kv-vector-rehash-stamp kv-vector) initial-stamp) + (signal-corrupt-hash-table hash-table)) + (let ((key-index (%rehash-and-find hash-table initial-stamp key))) + ;; If we see NIL here, it means that some other operation is racing + ;; to rehash. GETHASH can deal with that scenario, REMHASH can't. + (unless (fixnump key-index) (signal-corrupt-hash-table hash-table)) - (let ((key-index (%rehash-and-find hash-table initial-stamp key))) - ;; If we see NIL here, it means that some other operation is racing - ;; to rehash. GETHASH can deal with that scenario, REMHASH can't. - (unless (fixnump key-index) - (signal-corrupt-hash-table hash-table)) - (when (/= key-index 0) ; found - (let* ((index-vector (hash-table-index-vector hash-table)) - (start (aref index-vector bucket)) - (next-vector (hash-table-next-vector hash-table)) - (next (aref next-vector start)) - (pair-index (ash key-index -1))) - (if (if (= start pair-index) ; remove head of chain - (setf (aref index-vector bucket) next) - (do ((probe-limit (length next-vector)) - (predecessor start this) - (this next (aref next-vector this))) - ((zerop this)) - (declare (type index/2 predecessor this)) - (when (eql this pair-index) - (return (setf (aref next-vector predecessor) - (aref next-vector this)))) - (check-excessive-probes 1))) - (clear-slot pair-index hash-table kv-vector next-vector) - (signal-corrupt-hash-table hash-table)))))) - (%remhash/eq (key hash-table kv-vector next-vector start) - (do ((probe-limit (length next-vector)) - (predecessor start this) - (this (aref next-vector start) (aref next-vector this))) - ((zerop this) nil) - (declare (type index/2 predecessor this)) - (when (eq key (aref kv-vector (* 2 this))) - (setf (aref next-vector predecessor) (aref next-vector this)) - (return (clear-slot this hash-table kv-vector next-vector))) - (check-excessive-probes 1)))) - - (values (define-remhash remhash/eq eq) - (define-remhash remhash/eql eql) - (define-remhash remhash/equal equal) - (define-remhash remhash/equalp equalp) - (define-remhash remhash/any nil)))) - -(defun !cold-init-hash-table-methods () - (multiple-value-bind (weak eq eql equal equalp any) (get-puthash-definitions) - (setf (symbol-function 'puthash/weak) weak - (symbol-function 'puthash/eq) eq - (symbol-function 'puthash/eql) eql - (symbol-function 'puthash/equal) equal - (symbol-function 'puthash/equalp) equalp - (symbol-function 'puthash/any) any)) - (multiple-value-bind (eq eql equal equalp any) (get-remhash-definitions) - (setf (symbol-function 'remhash/eq) eq - (symbol-function 'remhash/eql) eql - (symbol-function 'remhash/equal) equal - (symbol-function 'remhash/equalp) equalp - (symbol-function 'remhash/any) any))) + (when (/= key-index 0) ; found + (let* ((index-vector (hash-table-index-vector hash-table)) + (start (aref index-vector bucket)) + (next-vector (hash-table-next-vector hash-table)) + (next (aref next-vector start)) + (pair-index (ash key-index -1))) + (if (if (= start pair-index) ; remove head of chain + (setf (aref index-vector bucket) next) + (do ((probe-limit (length next-vector)) + (predecessor start this) + (this next (aref next-vector this))) + ((zerop this)) + (declare (type index/2 predecessor this)) + (when (eql this pair-index) + (return (setf (aref next-vector predecessor) + (aref next-vector this)))) + (check-excessive-probes 1))) + (clear-slot pair-index hash-table kv-vector next-vector) + (signal-corrupt-hash-table hash-table)))))) + (%remhash/eq (key hash-table kv-vector next-vector start) + (do ((probe-limit (length next-vector)) + (predecessor start this) + (this (aref next-vector start) (aref next-vector this))) + ((zerop this) nil) + (declare (type index/2 predecessor this)) + (when (eq key (aref kv-vector (* 2 this))) + (setf (aref next-vector predecessor) (aref next-vector this)) + (return (clear-slot this hash-table kv-vector next-vector))) + (check-excessive-probes 1)))) + + (define-remhash remhash/eq eq) + (define-remhash remhash/eql eql) + (define-remhash remhash/equal equal) + (define-remhash remhash/equalp equalp) + (define-remhash remhash/any nil)) (defun remhash (key hash-table) "Remove the entry in HASH-TABLE associated with KEY. Return T if @@ -1868,7 +1893,7 @@ (when (hash-table-weak-p hash-table) (aver (eq (kv-vector-supplement kv-vector) hash-table))) ;; Remove address-sensitivity. - (unset-header-bits kv-vector sb-vm:vector-addr-hashing-flag) + (reset-array-flags kv-vector sb-vm:vector-addr-hashing-flag) ;; Do this only after unsetting the address-sensitive bit, ;; otherwise GC might come along and touch this bit again. (setf (kv-vector-rehash-stamp kv-vector) 0) @@ -1892,16 +1917,6 @@ ;;;; methods on HASH-TABLE -;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE -;;; when reconstructing HASH-TABLE. -;;; FIXME: synchronized? custom function? -(defun %hash-table-ctor-args (hash-table) - `(:test ',(hash-table-test hash-table) - :size ',(hash-table-size hash-table) - :rehash-size ',(hash-table-rehash-size hash-table) - :rehash-threshold ',(hash-table-rehash-threshold hash-table) - :weakness ',(hash-table-weakness hash-table))) - ;;; Return an association list representing the same data as HASH-TABLE. ;;; Iterate downward so that PUSH creates the result in insertion order. ;;; One the one hand, this should not to be construed as a guarantee about @@ -1919,38 +1934,78 @@ (push (cons k v) result))))) result)) -;;; Stuff an association list into HASH-TABLE. Return the hash table, -;;; so that we can use this for the *PRINT-READABLY* case in -;;; PRINT-OBJECT (HASH-TABLE T) without having to worry about LET -;;; forms and readable gensyms and stuff. -(defun %stuff-hash-table (hash-table alist) - (dolist (x alist) - (setf (gethash (car x) hash-table) (cdr x))) +;;; Stuff an association list, or a vector, into HASH-TABLE. Return the hash table, +;;; so that we can use this for the *PRINT-READABLY* case in PRINT-OBJECT (HASH-TABLE T) +;;; without having to worry about LET forms and readable gensyms and stuff. +(defun %stuff-hash-table (hash-table data) + (if (vectorp data) + (dovector (x data) (setf (gethash (car x) hash-table) (cdr x))) + (dolist (x data) (setf (gethash (car x) hash-table) (cdr x)))) hash-table) +;;; Return a list of keyword args and values to use for MAKE-HASH-TABLE +;;; when reconstructing HASH-TABLE. +(flet ((%hash-table-ctor (hash-table &aux (test (hash-table-test hash-table))) + (when (or (not (logtest (hash-table-flags hash-table) hash-table-userfun-flag)) + ;; If it has a named test function - it wasn't a lambda expression - + ;; and the table's hash-function is identical to the hash function + ;; dictated by *USER-HASH-TABLE-TESTS* for that test, we're OK. + ;; And it's not worth the risk of trying to reverse-engineer the hash + ;; function if all we have is a name. + (and test (eq (third (assoc test *user-hash-table-tests*)) + (hash-table-hash-fun hash-table)))) + `(make-hash-table + ,@(loop for (key accessor default) + in + (load-time-value + `((:test ,#'hash-table-test eql) + (:size ,#'hash-table-size ,+min-hash-table-size+) + (:rehash-size ,#'hash-table-rehash-size ,default-rehash-size) + (:rehash-threshold ,#'hash-table-rehash-threshold $1.0) + (:synchronized ,#'hash-table-synchronized-p nil) + (:weakness ,#'hash-table-weakness nil))) + for value = (funcall accessor hash-table) + unless (eql value default) + collect key + and + collect (if (self-evaluating-p value) + value + `',value)))))) + (defmethod print-object ((hash-table hash-table) stream) (declare (type stream stream)) - (cond ((or (not *print-readably*) (not *read-eval*)) - (print-unreadable-object (hash-table stream :type t :identity t) - (format stream - ":TEST ~S~@[ :HASH-FUNCTION ~S~] :COUNT ~S~@[ :WEAKNESS ~S~]" - (hash-table-test hash-table) - (when (and (eq (hash-table-test hash-table) 'eq) - (neq (hash-table-hash-fun hash-table) #'eq-hash)) - (hash-table-hash-fun hash-table)) - (hash-table-count hash-table) - (hash-table-weakness hash-table)))) - (t - (write-string "#." stream) - (write `(%stuff-hash-table (make-hash-table ,@(%hash-table-ctor-args - hash-table)) - ',(%hash-table-alist hash-table)) - :stream stream)))) + (let ((ctor (and *print-readably* *read-eval* (%hash-table-ctor hash-table)))) + (cond + ((not ctor) + ;; Perhaps we should add :SYNCHRONIZED to the string? + (print-unreadable-object (hash-table stream :type t :identity t) + (format stream + ":TEST ~S~@[ :HASH-FUNCTION ~S~] :COUNT ~S~@[ :WEAKNESS ~S~]" + (or (hash-table-test hash-table) (hash-table-test-fun hash-table)) + (when (logtest (hash-table-flags hash-table) hash-table-userfun-flag) + (hash-table-hash-fun hash-table)) + (hash-table-count hash-table) + (hash-table-weakness hash-table)))) + (t + (write-string "#." stream) + (let ((alist (%hash-table-alist hash-table))) + (write (if alist + `(%stuff-hash-table ,ctor ',alist) + ctor) + :stream stream)))))) (defmethod make-load-form ((hash-table hash-table) &optional environment) (declare (ignore environment)) - (values `(make-hash-table ,@(%hash-table-ctor-args hash-table)) - `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table)))) + (let ((ctor (%hash-table-ctor hash-table))) + (if ctor + (values ctor + ;; This uses a separate initform in case the hash table contains itself + ;; as either a key or value. + ;; FIXME: k/v pairs would take less space as a vector, not an alist. + (unless (zerop (hash-table-count hash-table)) + `(%stuff-hash-table ,hash-table ',(%hash-table-alist hash-table)))) + (error "~S is not externalizable" hash-table)))) +) ;;; This assignment has to occur some time after the defstruct. ;;; We don't call EQUALP on hash-table, so as late as possible is fine. @@ -1959,6 +2014,12 @@ (sb-kernel::assign-equalp-impl 'hash-table #'hash-table-equalp) #| +(defun memusage (x) + (+ (sb-vm::primitive-object-size (hash-table-pairs x)) + (acond ((hash-table-hash-vector x) (sb-vm::primitive-object-size it)) (t 0)) + (sb-vm::primitive-object-size (hash-table-index-vector x)) + (sb-vm::primitive-object-size (hash-table-next-vector x)))) + (defun show-address-sensitivity (&optional tbl) (flet ((show1 (tbl) (let ((kv (hash-table-pairs tbl)) diff -Nru sbcl-2.1.1/src/code/target-lflist.lisp sbcl-2.1.11/src/code/target-lflist.lisp --- sbcl-2.1.1/src/code/target-lflist.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-lflist.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -346,6 +346,6 @@ copy-of-next))) copy)))) (let ((new (copy-structure lfl))) - (setf (%instance-ref new (get-dsd-index linked-list head)) + (%instance-set new (get-dsd-index linked-list head) (copy-chain (list-head new))) new))) diff -Nru sbcl-2.1.1/src/code/target-load.lisp sbcl-2.1.11/src/code/target-load.lisp --- sbcl-2.1.1/src/code/target-load.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-load.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -74,8 +74,7 @@ (locally (declare (optimize (sb-c::type-check 0))) (setf sb-c::*current-path* (make-unbound-marker))) (if pathname - (let* ((info (sb-c::make-file-source-info - pathname (stream-external-format stream))) + (let* ((info (sb-c::make-file-stream-source-info stream)) (sb-c::*source-info* info)) (locally (declare (optimize (sb-c::type-check 0))) (setf sb-c::*current-path* (make-unbound-marker))) @@ -108,32 +107,28 @@ (invalid-fasl-expected condition) (invalid-fasl-fhsss condition))))) - -;;; The following comment preceded the pre 1.0.12.36 definition of -;;; LOAD; it may no longer be accurate: - -;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an -;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, -;; that CMU CL does not correctly record source file information when -;; LOADing a non-compiled file. Check whether this bug exists in SBCL -;; and fix it if so. - -(defun call-with-load-bindings (function stream) - (let* (;; FIXME: we should probably document the circumstances - ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't - ;; pathnames during LOAD. ANSI makes no exceptions here. - (*load-pathname* (handler-case (pathname stream) - ;; FIXME: it should probably be a type - ;; error to try to get a pathname for a - ;; stream that doesn't have one, but I - ;; don't know if we guarantee that. - (error () nil))) - (*load-truename* (when *load-pathname* - (handler-case (truename stream) - (file-error () nil)))) - ;; Bindings used internally. - (*load-depth* (1+ *load-depth*))) - (funcall function))) +(defun call-with-load-bindings (function stream arg pathname-designator) + (let* (;; FIXME: we should probably document the circumstances + ;; where *LOAD-PATHNAME* and *LOAD-TRUENAME* aren't + ;; pathnames during LOAD. ANSI makes no exceptions here. + (*load-pathname* (handler-case (pathname pathname-designator) + ;; FIXME: it should probably be a type + ;; error to try to get a pathname for a + ;; stream that doesn't have one, but I + ;; don't know if we guarantee that. + (error () nil))) + ;; FIXME: this ANSI-specified nonsense should have been an accessor call + ;; because eager binding might force dozens of syscalls to occur. + ;; And you wonder why I/O is slow. What a joke. Making this a symbol-macro + ;; that calls a function would be technically incompatible, but we could + ;; make it an unbound symbol and trap the access, stuffing in a value + ;; just-in-time. But BOUNDP would also need to hacked to return T. + (*load-truename* (when *load-pathname* + (handler-case (truename stream) + (file-error () nil)))) + ;; Bindings used internally. + (*load-depth* (1+ *load-depth*))) + (funcall function stream arg))) ;;; Returns T if the stream is a binary input stream with a FASL header. (defun fasl-header-p (stream &key errorp) @@ -150,7 +145,10 @@ (when p ; Can't do it non-destructively on non-seekable streams. (unwind-protect (let* ((header *fasl-header-string-start-string*) - (buffer (make-array (length header) :element-type '(unsigned-byte 8))) + ;; MISMATCH is called no matter how few octets are read in, + ;; so start with BUFFER completely 0-initialized. + (buffer (make-array (length header) :element-type '(unsigned-byte 8) + :initial-element 0)) (n 0)) (flet ((scan () (maybe-skip-shebang-line stream) @@ -177,34 +175,46 @@ (if-does-not-exist t) (external-format :default)) "Load the file given by FILESPEC into the Lisp environment, returning T on success." - (flet ((load-stream (stream faslp) - (when (and (fd-stream-p stream) + (labels ((load-stream (stream faslp) + (if (and (fd-stream-p stream) (eq (sb-impl::fd-stream-fd-type stream) :directory)) - (error 'simple-file-error - :pathname (pathname stream) - :format-control - "Can't LOAD a directory: ~s." - :format-arguments (list (pathname stream)))) - (dx-flet ((thunk () - (let (;; Bindings required by ANSI. - (*readtable* *readtable*) - (*package* (sane-package)) - ;; KLUDGE: I can't find in the ANSI spec where it says - ;; that DECLAIM/PROCLAIM of optimization policy should - ;; have file scope. CMU CL did this, and it seems - ;; reasonable, but it might not be right; after all, - ;; things like (PROCLAIM '(TYPE ..)) don't have file - ;; scope, and I can't find anything under PROCLAIM or - ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this - ;; behavior. Hmm. -- WHN 2001-04-06 - (sb-c::*policy* sb-c::*policy*) - (sb-c::*handled-conditions* sb-c::*handled-conditions*)) - (if faslp - (load-as-fasl stream verbose print) - (sb-c:with-compiler-error-resignalling - (load-as-source stream :verbose verbose - :print print)))))) - (call-with-load-bindings #'thunk stream)))) + (error 'simple-file-error + :pathname (pathname stream) + :format-control "Can't LOAD a directory: ~s." + :format-arguments (list (pathname stream))) + (call-with-load-bindings + #'load-stream-1 stream + faslp + ;; If you prefer *LOAD-PATHNAME* to reflect what the user specified prior + ;; to merging, then CALL-WITH-LOAD-BINDINGS is passed PATHSPEC, + ;; otherwise it is passed STREAM. + (cond ((and (not sb-c::*merge-pathnames*) + (typep pathspec '(or string pathname))) + pathspec) + (t stream))))) + (load-stream-1 (stream faslp) + (let (;; Bindings required by ANSI. + (*readtable* *readtable*) + (*package* (sane-package)) + ;; KLUDGE: I can't find in the ANSI spec where it says + ;; that DECLAIM/PROCLAIM of optimization policy should + ;; have file scope. CMU CL did this, and it seems + ;; reasonable, but it might not be right; after all, + ;; things like (PROCLAIM '(TYPE ..)) don't have file + ;; scope, and I can't find anything under PROCLAIM or + ;; COMPILE-FILE or LOAD or OPTIMIZE which justifies this + ;; behavior. Hmm. -- WHN 2001-04-06 + (sb-c::*policy* sb-c::*policy*) + (sb-c::*handled-conditions* sb-c::*handled-conditions*)) + (if faslp + (load-as-fasl stream verbose print) + ;; FIXME: if *EVALUATOR-MODE* is :INTERPRET, + ;; then this should have nothing whatsoever to do with + ;; compiler-error-resignaling. That's an artifact + ;; of using the compiler to perform interpretation. + (sb-c:with-compiler-error-resignalling + (load-as-source stream :verbose verbose :print print)))))) + (declare (truly-dynamic-extent #'load-stream-1)) ;; Case 1: stream. (when (streamp pathspec) @@ -320,7 +330,8 @@ (dotimes (i count) (destructuring-bind (name . offset) (svref vector i) (let ((next-offset (if (< (1+ i) count) (cdr (svref vector (1+ i))) size))) - (aver (> next-offset offset)) + ;; Must be in ascending order, but one address can have more than one name. + (aver (>= next-offset offset)) ;; store inclusive bounds on PC offset range and the function index (setf (gethash name ht) (list* offset (1- next-offset) (1+ i)))))))) diff -Nru sbcl-2.1.1/src/code/target-misc.lisp sbcl-2.1.11/src/code/target-misc.lisp --- sbcl-2.1.1/src/code/target-misc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-misc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -16,7 +16,7 @@ ;;; This is a tentative list of target features; many are removed later. ;;; :SB-XC is removed now, because it is plain wrong unless cross-compiling. -(defparameter *features* '#.(remove :sb-xc sb-xc:*features*) +(defvar *features* '#.(remove :sb-xc sb-xc:*features*) "a list of symbols that describe features provided by the implementation") (defconstant !sbcl-architecture #.(sb-cold::target-platform-keyword)) @@ -26,15 +26,16 @@ #+win32 (sb-win32::get-computer-name) #-win32 (truly-the simple-string (sb-unix:unix-gethostname))) -(declaim (type (or null string) *machine-version*)) -(defvar *machine-version*) +(declaim (type (or null simple-string) *machine-version*)) +(declaim (global *machine-version*)) (defun machine-version () "Return a string describing the version of the computer hardware we are running on, or NIL if we can't find any useful information." - (unless (boundp '*machine-version*) - (setf *machine-version* (get-machine-version))) - *machine-version*) + (if (boundp '*machine-version*) + *machine-version* + (setf *machine-version* + (awhen (get-machine-version) (possibly-base-stringize it))))) ;;; FIXME: Don't forget to set these in a sample site-init file. ;;; FIXME: Perhaps the functions could be SETFable instead of having the @@ -42,7 +43,7 @@ ;;; from ANSI 11.1.2.1.1 "Constraints on the COMMON-LISP Package ;;; for Conforming Implementations" it is kosher to add a SETF function for ;;; a symbol in COMMON-LISP.. -(declaim (type (or null string) *short-site-name* *long-site-name*)) +(declaim (type (or null simple-string) *short-site-name* *long-site-name*)) (define-load-time-global *short-site-name* nil "The value of SHORT-SITE-NAME.") (define-load-time-global *long-site-name* nil @@ -250,7 +251,7 @@ (lisp-implementation-version) subversions)))) -(defparameter sb-pcl::*!docstrings* nil) +(defvar sb-pcl::*!docstrings* nil) (defun (setf documentation) (string name doc-type) (declare (type (or null string) string)) (push (list string name doc-type) sb-pcl::*!docstrings*) diff -Nru sbcl-2.1.1/src/code/target-package.lisp sbcl-2.1.11/src/code/target-package.lisp --- sbcl-2.1.1/src/code/target-package.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-package.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -48,7 +48,7 @@ ;;;; sufficient, though interaction between parallel intern and use-package ;;;; needs to be considered with some care. -(!define-load-time-global *package-graph-lock* (sb-thread:make-mutex :name "Package Graph Lock")) +(define-load-time-global *package-graph-lock* nil) (defmacro with-package-graph ((&key) &body forms) ;; FIXME: Since name conflicts can be signalled while holding the @@ -157,7 +157,7 @@ ;; index. The returned value is a physical index. (named-let recurse ((start 0) (end (ash (length v) -1))) (declare (type (unsigned-byte 9) start end) - (optimize (sb-c::insert-array-bounds-checks 0))) + (optimize (sb-c:insert-array-bounds-checks 0))) (when (< start end) (let* ((i (ash (+ start end) -1)) (elt (keyfn (aref v (ash i 1))))) @@ -219,10 +219,6 @@ (sb-thread::with-recursive-system-lock ((info-env-mutex ,table-var)) ,@body))) -(defmethod make-load-form ((p package) &optional environment) - (declare (ignore environment)) - `(find-undeleted-package-or-lose ,(package-name p))) - ;;;; iteration macros (defmacro with-package-iterator ((mname package-list &rest symbol-types) &body body) @@ -547,7 +543,7 @@ ;;; making this a generic function then packages with custom package classes ;;; could hook into this to provide their own resolution. ;;; (Any such generic solution will turn the performance to crap, so let's not) -(declaim (inline find-package-using-package)) +(declaim (maybe-inline find-package-using-package)) (defun find-package-using-package (package-designator base) (let ((string (typecase package-designator (package @@ -579,11 +575,11 @@ See also: ADD-PACKAGE-LOCAL-NICKNAME, PACKAGE-LOCAL-NICKNAMES, REMOVE-PACKAGE-LOCAL-NICKNAME, and the DEFPACKAGE option :LOCAL-NICKNAMES." - (declare (explicit-check)) + (declare (explicit-check) + (inline find-package-using-package)) ;; We had a BOUNDP check on *PACKAGE* here, but it's effectless due to the ;; always-bound proclamation. (find-package-using-package package-designator *package*)) -(declaim (notinline find-package-using-package)) ;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and ;;; most other operations, are unspecified for deleted packages. We @@ -897,7 +893,7 @@ ;;; of STRING. ENTRY-HASH is the entry-hash of the string and length. ;;; If the symbol is found, then FORMS are executed; otherwise not. -(defmacro with-symbol (((symbol-var &optional (index-var (gensym))) table +(defmacro with-symbol (((symbol-var &optional (index-var (sb-xc:gensym))) table string length sxhash) &body forms) (with-unique-names (vec len h2 probed-thing name) `(let* ((,vec (package-hashtable-cells ,table)) @@ -1005,6 +1001,8 @@ implementation it is ~S." *!default-package-use-list*) (prog ((name (stringify-string-designator name)) (nicks (stringify-string-designators nicknames)) + (package (%make-package (make-package-hashtable internal-symbols) + (make-package-hashtable external-symbols))) clobber) :restart (when (find-package name) @@ -1014,20 +1012,20 @@ "Clobber existing package." "A package named ~S already exists" name) (setf clobber t)) + (when (and sb-c::*compile-time-eval* + (eq (sb-c::block-compile sb-c::*compilation*) t)) + (style-warn "Package creation forms limit block compilation and ~ + may cause failure with the use of specified entry ~ + points. Consider moving the package creation form outside the ~ + scope of a block compilation.")) (with-package-graph () - ;; Check for race, signal the error outside the lock. - (when (and (not clobber) (find-package name)) - (go :restart)) - (let ((package - (%make-package - name - (make-package-hashtable internal-symbols) - (make-package-hashtable external-symbols)))) - + ;; Check for race, signal the error outside the lock. + (when (and (not clobber) (find-package name)) + (go :restart)) + (setf (package-%name package) name) ;; Do a USE-PACKAGE for each thing in the USE list so that checking for ;; conflicting exports among used packages is done. (use-package use package) - ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal, ;; which would leave us with possibly-bad side effects from the earlier ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages, @@ -1044,10 +1042,10 @@ (with-package-names (table) (%register-package table name package)) (atomic-incf *package-names-cookie*) - (return package))) + (return package)) (bug "never"))) -(flet ((remove-names (package name-table) +(flet ((remove-names (package name-table keep-primary-name) ;; An INFO-HASHTABLE does not support REMHASH. We can simulate it ;; by changing the value to :DELETED. ;; (NIL would be preferable, but INFO-GETHASH does not return @@ -1058,6 +1056,7 @@ (dx-let ((names (cons (package-name package) (package-nicknames package))) (i 0)) + (when keep-primary-name (pop names)) (dolist (name names) ;; Aver that the following SETF doesn't insert a new pair. (aver (info-gethash name name-table)) @@ -1113,10 +1112,21 @@ (unless (eq package (find-package package-designator)) (go :restart)) ;; Do the renaming. - (remove-names package table) - (%register-package table name package) + ;; As a special case, do not allow the package to transiently disappear + ;; if PACKAGE-NAME is unchanged. This avoids glitches with build systems + ;; which try to operate on subcomponents in parallel, where one of the + ;; built subcomponents needs to add nicknames to an existing package. + ;; We could be clever here as well by not removing nicknames that + ;; will ultimately be re-added, but that didn't seem as critical. + (let ((keep-primary-name (string= name (package-%name package)))) + (remove-names package table keep-primary-name) + (unless keep-primary-name + (%register-package table name package))) (setf (package-%name package) name (package-%nicknames package) ())) + ;; Adding each nickname acquires and releases the table lock, + ;; because it's potentially interactive (on failure) and therefore + ;; not ideal to hold the lock for the entire duration. (%enter-new-nicknames package nicks)) (atomic-incf *package-names-cookie*) (return package)))) @@ -1160,13 +1170,14 @@ (dolist (used (package-use-list package)) (unuse-package used package)) (setf (package-%local-nicknames package) nil) - ;; FIXME: lacking a way to advise UNINTERN that this package - ;; is pending deletion, a large package conses successively - ;; many smaller tables for no good reason. - (do-symbols (sym package) - (unintern sym package)) + (flet ((nullify-home (symbols) + (dovector (x (package-hashtable-cells symbols)) + (when (and (symbolp x) (eq (symbol-package x) package)) + (%set-symbol-package x nil))))) + (nullify-home (package-internal-symbols package)) + (nullify-home (package-external-symbols package))) (with-package-names (table) - (remove-names package table) + (remove-names package table nil) (setf (package-%name package) nil ;; Setting PACKAGE-%NAME to NIL is required in order to ;; make PACKAGE-NAME return NIL for a deleted package as @@ -1852,12 +1863,12 @@ (defun pkg-name= (a b) (and (not (eql a 0)) (string= a b))) (defun !package-cold-init () + (setf *package-graph-lock* (sb-thread:make-mutex :name "Package Graph Lock")) (setf *package-names* (make-info-hashtable :comparator #'pkg-name= - :hash-function #'sxhash) - *package-nickname-ids* - (cons (make-info-hashtable :comparator #'pkg-name= - :hash-function #'sxhash) - 1)) + :hash-function #'sxhash)) + (setf *package-nickname-ids* (cons (make-info-hashtable :comparator #'pkg-name= + :hash-function #'sxhash) + 1)) (setf (sb-thread:mutex-name (info-env-mutex *package-names*)) "package names" (sb-thread:mutex-name (info-env-mutex (car *package-nickname-ids*))) "package nicknames") @@ -1968,7 +1979,7 @@ (logand start-state 3)))))) (when (zerop index) (return (advance start-state)))))) - (declare (optimize (sb-c::insert-array-bounds-checks 0))) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) (if (logtest start-state +package-iter-check-shadows+) (let ((shadows (package-%shadowing-symbols (this-package)))) (scan (not (member sym shadows :test #'string=)))) diff -Nru sbcl-2.1.1/src/code/target-pathname.lisp sbcl-2.1.11/src/code/target-pathname.lisp --- sbcl-2.1.1/src/code/target-pathname.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-pathname.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -337,7 +337,7 @@ (or (gethash key table) (let ((key (!allocate-pathname host device dir+hash name type version))) (when (typep host 'logical-host) - (setf (%instance-layout key) #.(find-layout 'logical-pathname))) + (setf (%instance-wrapper key) #.(find-layout 'logical-pathname))) (setf (gethash key table) key))))))) ;;; Vector of logical host objects, each of which contains its translations. diff -Nru sbcl-2.1.1/src/code/target-random.lisp sbcl-2.1.11/src/code/target-random.lisp --- sbcl-2.1.1/src/code/target-random.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-random.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -275,7 +275,6 @@ (ash y -1) (aref state (logand y 1))))) (values)) -#-sb-devel (declaim (start-block random %random-single-float %random-double-float random-chunk big-random-chunk)) @@ -325,13 +324,18 @@ (defun %random-single-float (arg state) (declare (type (single-float ($0f0)) arg) (type random-state state)) - (* arg - (- (make-single-float - (dpb (ash (random-chunk state) - (- sb-vm:single-float-digits n-random-chunk-bits)) - sb-vm:single-float-significand-byte - (single-float-bits $1.0))) - $1.0))) + (loop for candidate of-type single-float + = (* arg + (- (make-single-float + (dpb (ash (random-chunk state) + (- sb-vm:single-float-digits n-random-chunk-bits)) + sb-vm:single-float-significand-byte + (single-float-bits $1.0))) + $1.0)) + while (#+x86 eql ;; Can't use = due to 80-bit precision + #-x86 = + candidate arg) + finally (return candidate))) (declaim (ftype (function ((double-float ($0d0)) random-state) (double-float $0d0)) %random-double-float)) @@ -348,14 +352,17 @@ (defun %random-double-float (arg state) (declare (type (double-float ($0d0)) arg) (type random-state state)) - (* arg - (- (sb-impl::make-double-float - (dpb (ash (random-chunk state) - (- sb-vm:double-float-digits n-random-chunk-bits 32)) - sb-vm:double-float-significand-byte - (sb-impl::double-float-high-bits $1d0)) - (random-chunk state)) - $1d0))) + (loop for candidate of-type double-float + = (* arg + (- (sb-impl::make-double-float + (dpb (ash (random-chunk state) + (- sb-vm:double-float-digits n-random-chunk-bits 32)) + sb-vm:double-float-significand-byte + (sb-impl::double-float-high-bits $1d0)) + (random-chunk state)) + $1d0)) + while (= candidate arg) + finally (return candidate))) ;;; using a faster inline VOP #+x86 @@ -363,15 +370,19 @@ (declare (type (double-float ($0d0)) arg) (type random-state state)) (let ((state-vector (random-state-state state))) - (* arg - (- (sb-impl::make-double-float - (dpb (ash (sb-vm::random-mt19937 state-vector) - (- sb-vm:double-float-digits n-random-chunk-bits - sb-vm:n-word-bits)) - sb-vm:double-float-significand-byte - (sb-impl::double-float-high-bits $1d0)) - (sb-vm::random-mt19937 state-vector)) - $1d0)))) + (loop for candidate of-type double-float + = (* arg + (- (sb-impl::make-double-float + (dpb (ash (sb-vm::random-mt19937 state-vector) + (- sb-vm:double-float-digits n-random-chunk-bits + sb-vm:n-word-bits)) + sb-vm:double-float-significand-byte + (sb-impl::double-float-high-bits $1d0)) + (sb-vm::random-mt19937 state-vector)) + $1d0)) + ;; Can't use = due to 80-bit precision + while (eql candidate arg) + finally (return candidate)))) ;;;; random fixnums diff -Nru sbcl-2.1.1/src/code/target-signal-common.lisp sbcl-2.1.11/src/code/target-signal-common.lisp --- sbcl-2.1.1/src/code/target-signal-common.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-signal-common.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -41,7 +41,7 @@ (let (*unblock-deferrables-on-enabling-interrupts-p*) (unblock-deferrable-signals) (when (or *interrupt-pending* - #+sb-thruption *thruption-pending*) + #+sb-safepoint *thruption-pending*) (receive-pending-interrupt)) (funcall function)) (alien-funcall (extern-alien "block_deferrable_signals" @@ -50,10 +50,23 @@ (t (when (and enable-interrupts (or *interrupt-pending* - #+sb-thruption *thruption-pending*)) + #+sb-safepoint *thruption-pending*)) (receive-pending-interrupt)) (funcall function)))) +(defmacro pthread-sigmask (how new old) + `(let ((how ,how) (new ,new) (old ,old)) + (alien-funcall (extern-alien + #+sb-thread ,(or #+unix "pthread_sigmask" #-unix "sb_pthread_sigmask") + #-sb-thread ,(or #+netbsd "sb_sigprocmask" #-netbsd "sigprocmask") + (function void int system-area-pointer system-area-pointer)) + how + (cond ((system-area-pointer-p new) new) + (new (vector-sap new)) + (t (int-sap 0))) + (cond ((system-area-pointer-p old) old) + (old (vector-sap old)) + (t (int-sap 0)))))) (defun invoke-interruption (function) (without-interrupts @@ -69,16 +82,18 @@ (sb-thread::without-thread-waiting-for (:already-without-interrupts t) (allow-with-interrupts (nlx-protect (funcall function) - ;; We've been running with deferrables - ;; blocked in Lisp called by a C signal - ;; handler. If we return normally the sigmask - ;; in the interrupted context is restored. - ;; However, if we do an nlx the operating - ;; system will not restore it for us. - (when *unblock-deferrables-on-enabling-interrupts-p* - ;; This means that storms of interrupts - ;; doing an nlx can still run out of stack. - (unblock-deferrable-signals))) + ;; We've been running with blockable + ;; blocked in Lisp called by a C signal + ;; handler. If we return normally the sigmask + ;; in the interrupted context is restored. + ;; However, if we do an nlx the operating + ;; system will not restore it for us. + (when *unblock-deferrables-on-enabling-interrupts-p* + ;; This means that storms of interrupts + ;; doing an nlx can still run out of stack. + (pthread-sigmask SIG_UNBLOCK + (foreign-symbol-sap "blockable_sigset" t) + nil))) ;; The return value doesn't matter, just return 0 0)))))) @@ -86,4 +101,3 @@ "Convenience macro on top of INVOKE-INTERRUPTION." `(dx-flet ((interruption () ,@body)) (invoke-interruption #'interruption))) - diff -Nru sbcl-2.1.1/src/code/target-signal.lisp sbcl-2.1.11/src/code/target-signal.lisp --- sbcl-2.1.1/src/code/target-signal.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-signal.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -27,6 +27,25 @@ (pgrp int) (signal int)) +;;; A macro, because OS-THREAD is a WORD which could cause boxing if passed +;;; to a function. +(defmacro pthread-kill (os-thread signal) + (declare (ignorable os-thread)) + ;; If no threads, pthread_kill() won't exist since we didn't link with -lpthread. + ;; And raise() - as we use it - can't fail, so just ignore the result. + ;; (The signal number is always SIGURG or SIGINT, and the process is obviously not dead) + ;; This isn't used on win32 so we don't need to change the symbol to sb_pthr_kill there. + #-sb-thread `(raise ,signal) + #+sb-thread + `(unless (= 0 (alien-funcall (extern-alien "pthread_kill" + (function int unsigned int)) + ,os-thread ,signal)) + (error "pthread_kill() failed"))) + +;;; raise() is defined to send the signal to pthread_self() if multithreaded. +(defmacro raise (signal) + `(alien-funcall (extern-alien "raise" (function int int)) ,signal)) + ;;; Reset the current set of masked signals (those being blocked from ;;; delivery). ;;; @@ -42,28 +61,11 @@ (with-alien ((%unblock-gc-signals (function void) :extern "unblock_gc_signals")) (alien-funcall %unblock-gc-signals) nil)) - -;;;; interface to enabling and disabling signal handlers - -;;; Note on the SYNCHRONOUS argument: On builds without pseudo-atomic, -;;; we have no way of knowing whether interrupted code was in an -;;; allocation sequence, and cannot delay signals until after -;;; allocation. Any signal that can occur asynchronously must be -;;; considered unsafe for immediate execution, and the invocation of its -;;; lisp handler will get delayed into a newly spawned signal handler -;;; thread. However, there are signals which we must handle -;;; immediately, because they occur synchonously (hence the boolean flag -;;; SYNCHRONOUS to this function), luckily implying that the signal -;;; happens only in specific places (illegal instructions, floating -;;; point instructions, certain system calls), hopefully ruling out the -;;; possibility that we would trigger it during allocation. +;;;; interface to installing signal handlers -;;; FIXME: terrible name. doesn't actually "enable" in the sense of unmasking. -(defun enable-interrupt (signal handler &key synchronous) +(defun enable-interrupt (signal handler) (declare (type (or function (member :default :ignore)) handler)) - (when synchronous - (error ":SYNCHRONOUS is broken and should not be used")) (%install-handler signal handler) ;; This used to return the previously installed handler, if any. ;; It no longer does, but the old handler can be obtained via SAP-REF-LISPOBJ @@ -75,45 +77,28 @@ nil) (defun %install-handler (signal handler) - (flet ((run-handler (signo info-sap context-sap) - #-(or c-stack-is-control-stack sb-safepoint) ;; able to do that in interrupt_handle_now() - (unblock-gc-signals) - (in-interruption () - (funcall handler signo info-sap context-sap)))) - (with-pinned-objects (#'run-handler) - ;; 0 and 1 probably coincide with SIG_DFL and SIG_IGN, but those - ;; constants are opaque. We use our own explicit translation - ;; of them in the C install_handler() argument convention. - (with-alien ((%sigaction (function void int unsigned) :extern "install_handler")) - (alien-funcall %sigaction - signal + ;; 0 and 1 should coincide with SIG_DFL and SIG_IGN, but in theory those values + ;; are opaque. We use our own explicit translation of 0 and 1 to them + ;; in the C install_handler() argument passing convention. + (with-alien ((%sigaction (function void int unsigned) :extern "install_handler")) + #+sb-safepoint + (alien-funcall %sigaction signal + (case handler + (:default 0) + (:ignore 1) + (t (sb-kernel:get-lisp-obj-address handler)))) + #-sb-safepoint + (flet ((run-handler (signo info-sap context-sap) + #-(or c-stack-is-control-stack sb-safepoint) ;; able to do that in interrupt_handle_now() + (unblock-gc-signals) + (in-interruption () (funcall handler signo info-sap context-sap)))) + (with-pinned-objects (#'run-handler) + (alien-funcall %sigaction signal (case handler (:default 0) (:ignore 1) (t (sb-kernel:get-lisp-obj-address #'run-handler))))))) nil) - -;;;; Support for signal handlers which aren't. -;;;; -;;;; On safepoint builds, user-defined Lisp signal handlers do not run -;;;; in the handler for their signal, because we have no pseudo atomic -;;;; mechanism to prevent handlers from hitting during allocation. -;;;; Rather, the signal spawns off a fresh native thread, which calls -;;;; into lisp with a fake context through this callback: - -#+sb-safepoint-strictly -(defun signal-handler-callback (run-handler signal args) - ;; SAPs are dx allocated, close over the values, not the SAPs. - (let ((thread (without-gcing - ;; Hold off GCing until *current-thread* is set up - (setf sb-thread:*current-thread* - (sb-thread::make-signal-handling-thread :name "signal handler" - :signal-number signal)))) - (info (sap-ref-sap args 0)) - (context (sap-ref-sap args sb-vm:n-word-bytes))) - (dx-flet ((callback () - (funcall run-handler signal info context))) - (sb-thread::run thread nil #'callback nil)))) ;;;; default LISP signal handlers @@ -180,17 +165,18 @@ (sb-thread:interrupt-thread (sb-thread::foreground-thread) #'interrupt-it))) -#-sb-wtimer (defun sigalrm-handler (signal info context) (declare (ignore signal info context)) - (declare (type system-area-pointer context)) + ;; Safepoint invokes the "signal handler" without a signal context, + ;; since it's not a signal handler. + #-sb-safepoint (declare (type system-area-pointer context)) (sb-impl::run-expired-timers)) (defun sigterm-handler (signal code context) (declare (ignore signal code context)) (exit)) -#-sb-thruption +#-sb-safepoint ;;; SIGURG is not used in SBCL for its original purpose, instead it's ;;; for signalling a thread that it should look at its interruption ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is @@ -205,18 +191,6 @@ (declare (ignore signal code context)) (sb-impl::get-processes-status-changes)) -(defmacro pthread-sigmask (how new old) - `(let ((how ,how) (new ,new) (old ,old)) - (alien-funcall (extern-alien - #+sb-thread ,(or #+unix "pthread_sigmask" #-unix "sb_pthread_sigmask") - #-sb-thread ,(or #+netbsd "sb_sigprocmask" #-netbsd "sigprocmask") - (function void int system-area-pointer system-area-pointer)) - how - (cond ((system-area-pointer-p new) new) - (new (vector-sap new)) - (t (int-sap 0))) - (if old (vector-sap old) (int-sap 0))))) - (defun sb-kernel:signal-cold-init-or-reinit () "Enable all the default signals that Lisp knows how to deal with." (%install-handler sigint #'sigint-handler) @@ -229,17 +203,27 @@ (write-string ";;;; SIGBUS handler not installed " sb-sys:*stderr*)) #-(or linux android) (%install-handler sigsys #'sigsys-handler) - #-sb-wtimer (%install-handler sigalrm #'sigalrm-handler) - #-sb-thruption (%install-handler sigurg #'sigurg-handler) + (%install-handler sigalrm #'sigalrm-handler) + #-sb-safepoint (%install-handler sigurg #'sigurg-handler) (%install-handler sigchld #'sigchld-handler) ;; Don't want to silently quit on broken pipes. (%install-handler sigpipe :ignore) ;; Undo the effect of block_blockable_signals() from right at the top of sbcl_main() ;; and (if pertinent) blocking stop-for-GC somewhere thereafter. - (dx-let ((mask (make-array sb-unix::sizeof-sigset_t :element-type '(unsigned-byte 8) - :initial-element 0))) + (dx-let ((mask (make-array sizeof-sigset_t :element-type '(unsigned-byte 8) + :initial-element 0))) (with-pinned-objects (mask) - (pthread-sigmask sb-unix::SIG_SETMASK mask nil))) + #+(and unix sb-safepoint) + ;; For safepoints we unblock SIGURG (to receive interrupt-thread), + ;; SIGPROF (because why not), and SIGPIPE (because it's synchronous + ;; and not in deferrables). Everything else stays blocked. + (with-alien ((sigaddset (function int system-area-pointer int) :extern "sigaddset")) + (alien-funcall sigaddset (vector-sap mask) sigurg) + (alien-funcall sigaddset (vector-sap mask) sigprof) + (alien-funcall sigaddset (vector-sap mask) sigpipe) + (pthread-sigmask SIG_UNBLOCK mask nil)) + ;; The normal thing is to start with no signals blocked + #-(and unix sb-safepoint) (pthread-sigmask SIG_SETMASK mask nil))) (values)) ;;;; etc. @@ -247,3 +231,28 @@ ;;; extract si_code from siginfo_t (define-alien-routine ("siginfo_code" siginfo-code) int (info system-area-pointer)) + +;;;; On safepoint builds, user-defined Lisp signal handlers all run +;;;; in one thread that waits for signals. +;;;; Keyboard interrupts work by forwarding SIGINT from that thread +;;;; to the foreground thread via INTERRUPT-THREAD, which is the only +;;;; quasi-asynchronous signal allowed to run in arbitrary threads. +#+sb-safepoint +(progn +(define-load-time-global *sighandler-thread* nil) +(declaim (type (or sb-thread:thread null) *sighandler-thread*)) +(defun signal-handler-loop () + ;; We could potentially use sigwaitinfo() to obtain more information about the signal, + ;; but I don't see the point. This is just minimal functionality. + (with-alien ((sigwait (function int system-area-pointer (* int)) :extern "sigwait") + (mask (array (unsigned 8) #.sizeof-sigset_t)) + (num int)) + (pthread-sigmask SIG_BLOCK nil (alien-sap mask)) ; Retrieve current mask + (loop (let ((result (alien-funcall sigwait (alien-sap mask) (addr num)))) + (when (and (= result 0) (= num sigterm) (not *sighandler-thread*)) + (return)) + (when (and (= result 0) (> num 0)) + (let ((fun (sap-ref-lispobj (foreign-symbol-sap "lisp_sig_handlers" t) + (ash num sb-vm:word-shift)))) + (when (functionp fun) + (funcall fun num nil nil))))))))) diff -Nru sbcl-2.1.1/src/code/target-stream.lisp sbcl-2.1.11/src/code/target-stream.lisp --- sbcl-2.1.1/src/code/target-stream.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-stream.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -191,6 +191,7 @@ read-char unread-char read-byte read-sequence/read-function write-sequence/write-function stream-element-mode)) + (clear-info :function :inlinep name) (clear-info :function :inlining-data name)) ;;; Can all the ANSI- function names be removed now? Maybe? (push '("SB-IMPL" ansi-stream-peek-char ansi-stream-unread-char) diff -Nru sbcl-2.1.1/src/code/target-sxhash.lisp sbcl-2.1.11/src/code/target-sxhash.lisp --- sbcl-2.1.1/src/code/target-sxhash.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-sxhash.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -27,7 +27,7 @@ (let ((word ;; threads imply gencgc. use the per-thread alloc region pointer #+sb-thread - (sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-alloc-region-slot)) + (sap-int (sb-vm::current-thread-offset-sap sb-vm::thread-boxed-tlab-slot)) #+(and (not sb-thread) cheneygc) (sap-int (dynamic-space-free-pointer)) ;; dynamic-space-free-pointer increments only when a page is full. @@ -92,9 +92,12 @@ (defun %instance-sxhash (instance) ;; to avoid consing in fmix (declare (inline #+64-bit murmur3-fmix64 #-64-bit murmur3-fmix32)) - ;; FIXME: this special case might be removable, but there are callers - ;; of sxhash on layouts due to the expansion of TYPECASE. - (when (typep instance 'layout) + ;; LAYOUT must not acquire an extra slot for the stable hash, + ;; because the bitmap length is derived from the instance length. + ;; It would probably be simple to eliminate this as a special case + ;; by ensuring that instances of LAYOUT commence life with a trailing + ;; hash slot and the SB-VM:HASH-SLOT-PRESENT-FLAG set. + (when (typep instance 'sb-vm:layout) ;; This might be wrong if the clos-hash was clobbered to 0 (return-from %instance-sxhash (layout-clos-hash instance))) ;; Non-simple cases: no hash slot, and either unhashed or hashed-not-moved. @@ -196,27 +199,22 @@ (mix-chunk (word) `(setq result (word-mix ,word result))) (mix-remaining (word) - ;; N-BITS-REMAINING is between 1 inclusive and N-WORD-BITS exclusive - (let ((mask - #+little-endian ; if all except 1 bit remain, right-shift by 1, etc - `(ash most-positive-word (- n-bits-remaining sb-vm:n-word-bits)) - #+big-endian ; same, except left-shift (modularly) - `(logand most-positive-word - (ash most-positive-word - (- sb-vm:n-word-bits n-bits-remaining))))) - `(setq result (word-mix (logand ,word ,mask) result))))) + ;; In the current implementation of bit operations, they may leave random + ;; bits in an ignored suffix of bits, hence the need for a masking operation. + ;; (See examples above DEF-BIT-ARRAY-OP) + ;; N-BITS-REMAINING is between 1 inclusive and N-WORD-BITS exclusive. + ;; Produce a mask of 1s spanning the remaining bits, which would be + ;; (- n-word-bits n-bits-remaining) and logically AND it with word. + ;; The mask is equal mod N-WORD-BITS to (- n-bits-remaining). + ;; SHIFT-TOWARDS-START clips the shift count explicitly if the CPU doesn't. + `(mix-chunk (logand (shift-towards-start most-positive-word + (- n-bits-remaining)) + ,word)))) (defun %sxhash-simple-bit-vector (x) (with-hash (result (length (truly-the simple-bit-vector x))) (multiple-value-bind (n-full-words n-bits-remaining) (floor (length x) sb-vm:n-word-bits) (dotimes (i n-full-words) (mix-chunk (%vector-raw-bits x i))) (when (plusp n-bits-remaining) - ;; FIXME: Do we really have to mask off bits of the final word? - ;; I don't think so, given that remaining bits are invariantly zero. - ;; Maybe this has to do with stack-allocated vectors? - ;; Either that, or it anticipates a change wherein we do not always - ;; prezero unboxed vectors unless :INITIAL-ELEMENT was specified. - ;; (i.e. you'd get random bytes, and so the only known good bits/bytes - ;; would appear where you had performed a SETF on them) (mix-remaining (%vector-raw-bits x n-full-words)))) (logand result sb-xc:most-positive-fixnum))) (defun %sxhash-bit-vector (bit-vector) @@ -345,7 +343,7 @@ (logxor 72185131 (sxhash (char-code x)))) ; through DEFTRANSFORM (funcallable-instance - (if (layout-for-pcl-obj-p (%fun-layout x)) + (if (logtest (layout-flags (%fun-layout x)) +pcl-object-layout-flag+) ;; We have a hash code, so might as well use it. (fsc-instance-hash x) ;; funcallable structure, not funcallable-standard-object @@ -355,62 +353,72 @@ ;;;; the PSXHASH function -;;; To avoid "note: Return type not fixed values ..." -(declaim (ftype (sfunction (number) hash-code) number-psxhash)) - ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing +(macrolet ((hash-float (type key) + ;; Floats that represent integers must hash as the integer would. + (let ((lo (coerce most-negative-fixnum type)) + (hi (coerce most-positive-fixnum type))) + `(let ((key ,key)) + (cond ( ;; This clause allows FIXNUM-sized integer + ;; values to be handled without consing. + (<= ,lo key ,hi) + (multiple-value-bind (q r) (floor (the (,type ,lo ,hi) key)) + (if (zerop (the ,type r)) + (sxhash q) + (sxhash (coerce key 'double-float))))) + ((float-infinity-p key) + ;; {single,double}-float infinities are EQUALP + (if (minusp key) + (sxhash sb-ext:single-float-negative-infinity) + (sxhash sb-ext:single-float-positive-infinity))) + (t + (multiple-value-bind (q r) (floor key) + (if (zerop (the ,type r)) + (sxhash q) + (sxhash (coerce key 'double-float)))))))))) (defun psxhash (key) (declare (optimize speed)) (labels - ((array-psxhash (key depthoid) - (declare (type array key)) - (declare (type (integer 0 #.+max-hash-depthoid+) depthoid)) - (if (vectorp key) - ;; VECTORs have to be treated specially because ANSI specifies - ;; that we must respect fill pointers. - (let ((result 572539)) - (declare (type hash-code result)) - (mixf result (length key)) - (when (plusp depthoid) - (decf depthoid) - (macrolet ((traverse (element-hasher) - `(dotimes (i (length key)) - (declare (type index i)) - (mixf result - ,(ecase element-hasher - (character `(char-code (char-upcase (aref key i)))) - (integer `(sxhash (aref key i))) - (number `(number-psxhash (aref key i))) - (:default `(%psxhash (aref key i) depthoid))))))) - (typecase key - ;; There are two effects from the typecase: - ;; 1. using a specialized array reffer - ;; 2. dispatching to a specific hash function - (simple-base-string (traverse character)) ; both effects - ((simple-array character (*)) (traverse character)) ; "" - (simple-vector (traverse :default)) ; effect #1 only - ((simple-array (unsigned-byte 8) (*)) (traverse integer)) ; both effects - ;; this seems arbitrary. I think (simple-array word (*)) is more popular! - ((simple-array fixnum (*)) (traverse integer)) ; both effects - (string (traverse character)) ; effect #2 only - ((vector t) (traverse :default)) ; weed out non-simple T vector from final case - (t (traverse number))))) ; all else - effect #2 only - result) - ;; Any other array can be hashed by working with its underlying - ;; one-dimensional physical representation. - (let ((result 60828)) - (declare (type fixnum result)) - (dotimes (i (array-rank key)) - (mixf result (%array-dimension key i))) - (when (plusp depthoid) - (decf depthoid) - (with-array-data ((key key) (start) (end)) - (let ((getter (truly-the function (svref %%data-vector-reffers%% - (%other-pointer-widetag key))))) - (loop for i from start below end - do (mixf result (%psxhash (funcall getter key i) depthoid)))))) - result))) - (structure-object-psxhash (key depthoid) + ((data-vector-hash (data start end depthoid) + (declare (optimize (sb-c:insert-array-bounds-checks 0))) + (let ((result 572539)) + (declare (type hash-code result)) + (when (plusp depthoid) + (decf depthoid) + (macrolet ((traverse (et &aux (elt '(aref data i))) + `(let ((data (truly-the (simple-array ,et (*)) data))) + (loop for i fixnum from (truly-the fixnum start) + below (truly-the fixnum end) + do (mixf result + ,(case et + ((t) `(%psxhash ,elt depthoid)) + ((base-char character) + `(char-code (char-upcase ,elt))) + (single-float `(sfloat-psxhash ,elt)) + (double-float `(dfloat-psxhash ,elt)) + ;; the remaining types are integers and complex numbers. + ;; COMPLEX will cons here, as will word-sized + ;; integers. Nothing else should though. + (t `(sxhash ,elt)))))))) ; xformed + (typecase data + ;; There are two effects of this typecase: + ;; 1. using an optimized array reader + ;; 2. dispatching to a type-specific hash function + (simple-vector (traverse t)) ; effect #1 only + (simple-base-string (traverse base-char)) ; both effects + #+sb-unicode (simple-character-string (traverse character)) ; both + ((simple-array single-float (*)) (traverse single-float)) ; and so on + ((simple-array double-float (*)) (traverse double-float)) + ;; (SIMPLE-ARRAY WORD (*)) would be helpful to avoid consing, + ;; but there is no SXHASH transform on word-sized integers. + ;; It might be possible to do something involving WORD-MIX. + ((simple-array fixnum (*)) (traverse fixnum)) + (t + (let ((getter (svref %%data-vector-reffers%% (%other-pointer-widetag data)))) + (loop for i fixnum from (truly-the fixnum start) below (truly-the fixnum end) + do (mixf result (number-psxhash (funcall getter data i))))))))) + result)) + (structure-object-psxhash (key depthoid) ;; Compute a PSXHASH for KEY. Salient points: ;; * It's not enough to use the bitmap to figure out how to mix in raw slots. ;; The floating-point types all need special treatment. And we want to avoid @@ -455,15 +463,16 @@ (let ((cplx (%raw-instance-ref/complex-double key i))) ,(mix-float '(realpart cplx) $0d0) ,(mix-float '(imagpart cplx) $0d0))))))) - (let* ((layout (%instance-layout key)) - (result (layout-clos-hash layout))) + (let* ((wrapper (%instance-wrapper key)) + (result (wrapper-clos-hash wrapper))) (declare (type fixnum result)) (when (plusp depthoid) (let ((max-iterations depthoid) - (depthoid (1- depthoid))) + (depthoid (1- depthoid)) + (dd (wrapper-dd wrapper))) (declare (index max-iterations)) - (if (/= (layout-bitmap layout) +layout-all-tagged+) - (let ((slots (dd-slots (layout-dd layout)))) + (if (/= (sb-kernel::dd-bitmap dd) +layout-all-tagged+) + (let ((slots (dd-slots dd))) (loop (unless slots (return)) (let* ((slot (pop slots)) (rsd-index+1 (rsd-index+1 slot)) @@ -484,97 +493,77 @@ (incf i) (if (zerop (decf max-iterations)) (return))))))) result))) - (%psxhash (key depthoid) - (typecase key - (array (array-psxhash key depthoid)) - (structure-object - (cond ((hash-table-p key) - ;; This is a purposely not very strong hash so that it does not make any - ;; distinctions that EQUALP does not make. Computing a hash of the k/v pair - ;; vector would incorrectly take insertion order into account. - (mix (mix 103924836 (hash-table-count key)) - (sxhash (hash-table-test key)))) - ((pathnamep key) (pathname-sxhash key)) - (t - (structure-object-psxhash key depthoid)))) - (list - (cond ((null key) - (the fixnum 480929)) - ((eql depthoid 0) - (the fixnum 779578)) - (t - (let ((depthoid (1- (truly-the (integer 0 #.+max-hash-depthoid+) - depthoid)))) - (mix (%psxhash (car key) depthoid) - (%psxhash (cdr key) depthoid)))))) - (number (number-psxhash key)) - (character (char-code (char-upcase key))) - (t (sxhash key))))) + (sfloat-psxhash (key) + (declare (single-float key)) + (hash-float single-float key)) + (dfloat-psxhash (key) + (declare (double-float key)) + (hash-float double-float key)) + (number-psxhash (key) + (declare (type number key) + (muffle-conditions compiler-note)) + (macrolet ((hash-complex (hasher) + `(if (zerop (imagpart key)) + (,hasher (realpart key)) + ;; I'm not sure what the point of an additional mix step + ;; with a constant was. Maybe trying to get it not to hash + ;; like a ratio whose num/den are equal to the real and imag + ;; parts of a complex number? That seems silly. + ;; But sure, let's do something like it, but simpler. + ;; (It might hash like a cons of these integers anyway) + (logand (lognot (mix (,hasher (realpart key)) (,hasher (imagpart key)))) + most-positive-fixnum)))) + (etypecase key + (integer (sxhash key)) + (single-float (sfloat-psxhash key)) + (double-float (dfloat-psxhash key)) + (rational (if (and (<= most-negative-double-float + key + most-positive-double-float) + (= (coerce key 'double-float) key)) + (sxhash (coerce key 'double-float)) + ;; a rational for which '=' does not return T when compared + ;; to itself cast as double-float need to have the same hash + ;; as any float. That's why this case is legitimate. + (sxhash key))) + ((complex double-float) (hash-complex dfloat-psxhash)) + ((complex single-float) (hash-complex sfloat-psxhash)) + ((complex rational) (hash-complex number-psxhash))))) + (%psxhash (key depthoid) + (typecase key + (array + (if (vectorp key) + (with-array-data ((a key) (start) (end) :force-inline t :check-fill-pointer t) + (mix (data-vector-hash a start end depthoid) (length key))) + (with-array-data ((a key) (start) (end) :force-inline t :array-header-p t) + (let ((result (data-vector-hash a start end depthoid))) + (dotimes (i (array-rank key) result) + (mixf result (%array-dimension key i))))))) + (structure-object + (cond ((hash-table-p key) + ;; This is a purposely not very strong hash so that it does not make any + ;; distinctions that EQUALP does not make. Computing a hash of the k/v pair + ;; vector would incorrectly take insertion order into account. + (mix (mix 103924836 (hash-table-count key)) + (sxhash (hash-table-test key)))) + ((pathnamep key) (pathname-sxhash key)) + (t + (structure-object-psxhash key depthoid)))) + (list + (cond ((null key) + (the fixnum 480929)) + ((eql depthoid 0) + (the fixnum 779578)) + (t + (let ((depthoid (1- (truly-the (integer 0 #.+max-hash-depthoid+) + depthoid)))) + (mix (%psxhash (car key) depthoid) + (%psxhash (cdr key) depthoid)))))) + (number (number-psxhash key)) + (character (char-code (char-upcase key))) + (t (sxhash key))))) (%psxhash key +max-hash-depthoid+))) - -(defun number-psxhash (key) - (declare (type number key) - (explicit-check) - (muffle-conditions compiler-note) - (optimize speed)) - (flet ((sxhash-double-float (val) - (declare (type double-float val)) - ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the - ;; resulting code works without consing. (In Debian cmucl 2.4.17, - ;; it didn't.) - (sxhash val))) - (macrolet ((hash-float (type key) - (let ((lo (coerce most-negative-fixnum type)) - (hi (coerce most-positive-fixnum type))) - `(let ((key ,key)) - (cond ( ;; This clause allows FIXNUM-sized integer - ;; values to be handled without consing. - (<= ,lo key ,hi) - (multiple-value-bind (q r) - (floor (the (,type ,lo ,hi) key)) - (if (zerop (the ,type r)) - (sxhash q) - (sxhash-double-float - (coerce key 'double-float))))) - ((float-infinity-p key) - ;; {single,double}-float infinities are EQUALP - (if (minusp key) - (sxhash sb-ext:single-float-negative-infinity) - (sxhash sb-ext:single-float-positive-infinity))) - (t - (multiple-value-bind (q r) (floor key) - (if (zerop (the ,type r)) - (sxhash q) - (sxhash-double-float - (coerce key 'double-float))))))))) - (hash-complex (&optional (hasher '(number-psxhash))) - `(if (zerop (imagpart key)) - (,@hasher (realpart key)) - (let ((result 330231)) - (declare (type fixnum result)) - (mixf result (,@hasher (realpart key))) - (mixf result (,@hasher (imagpart key))) - result)))) - (etypecase key - (integer (sxhash key)) - (float (macrolet () - (etypecase key - (single-float (hash-float single-float key)) - (double-float (hash-float double-float key)) - #+long-float - (long-float (error "LONG-FLOAT not currently supported"))))) - (rational (if (and (<= most-negative-double-float - key - most-positive-double-float) - (= (coerce key 'double-float) key)) - (sxhash-double-float (coerce key 'double-float)) - (sxhash key))) - ((complex double-float) - (hash-complex (hash-float double-float))) - ((complex single-float) - (hash-complex (hash-float single-float))) - ((complex rational) - (hash-complex)))))) +) ; end MACROLET ;;; Semantic equivalent of SXHASH, but better-behaved for function names. ;;; It performs more work by not cutting off as soon in the CDR direction. diff -Nru sbcl-2.1.1/src/code/target-thread.lisp sbcl-2.1.11/src/code/target-thread.lisp --- sbcl-2.1.1/src/code/target-thread.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-thread.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -15,8 +15,6 @@ (export '(%thread-local-references current-thread-sap get-spinlock - pthread-kill - raise release-spinlock spinlock with-deathlok @@ -243,13 +241,6 @@ (let ((new (avl-insert old addr ,thread))) (when (eq old (setq old (sb-ext:cas *all-threads* old new))) (return))))))) -(defvar *default-alloc-signal* nil) -;;; *ALLOC-SIGNAL* is in PER-THREAD-C-INTERFACE-SYMBOLS. Hence it doesn't require -;;; the aspect of DEFINE-THREAD-LOCAL that ensures a nonzero TLS index. -;;; (In fact you must not use DEFINE-THREAD-LOCAL, because it's incompatible -;;; with the numbering assigned to the C interface symbols) -(defvar sb-vm:*alloc-signal*) - (defun list-all-threads () "Return a list of the live threads. Note that the return value is potentially stale even before the function returns, as new threads may be @@ -267,19 +258,16 @@ ;;; used by debug-int.lisp to access interrupt contexts +(declaim (inline current-thread-sap)) +(defun current-thread-sap () + #+sb-thread (sb-vm::current-thread-offset-sap sb-vm::thread-this-slot) + #-sb-thread (extern-alien "all_threads" system-area-pointer)) + #-sb-thread (progn (declaim (inline sb-vm::current-thread-offset-sap)) (defun sb-vm::current-thread-offset-sap (n) - (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) - (* n sb-vm:n-word-bytes)))) - -(declaim (inline current-thread-sap)) -(defun current-thread-sap () - #+sb-thread - (sb-vm::current-thread-offset-sap sb-vm::thread-this-slot) - #-sb-thread - (int-sap 0)) + (sap-ref-sap (current-thread-sap) (* n sb-vm:n-word-bytes)))) (sb-ext:define-load-time-global *initial-thread* nil) @@ -316,6 +304,8 @@ `(setf (thread-control-stack-start ,this) (get-lisp-obj-address sb-vm:*control-stack-start*) (thread-control-stack-end ,this) (get-lisp-obj-address sb-vm:*control-stack-end*))) +(defvar *session*) + ;;; Not uncoincidentally, the variables assigned here are also ;;; listed in SB-KERNEL::*SAVE-LISP-CLOBBERED-GLOBALS* (defun init-main-thread () @@ -331,6 +321,7 @@ (init-thread-local-storage thread) (setf *initial-thread* thread) (setf *joinable-threads* nil) + (setq *session* (new-session thread)) (setq *all-threads* (avl-insert nil (sb-thread::thread-primitive-thread sb-thread:*current-thread*) @@ -412,15 +403,6 @@ #+sb-thread (progn - (declaim (inline %block-deferrable-signals)) - (define-alien-routine ("block_deferrable_signals" %block-deferrable-signals) - void - (where unsigned) - (old unsigned)) - - (defun block-deferrable-signals () - (%block-deferrable-signals 0 0)) - #+sb-futex (progn (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) @@ -750,6 +732,81 @@ (declare (dynamic-extent #'cas)) (%%wait-for #'cas stop-sec stop-usec))))) +#+mutex-benchmarks +(symbol-macrolet ((val (mutex-state mutex))) + (export '(wait-for-mutex-algorithm-2 + wait-for-mutex-algorithm-3 + wait-for-mutex-2-partial-inline + wait-for-mutex-3-partial-inline)) + (declaim (sb-ext:maybe-inline %wait-for-mutex-algorithm-2 + %wait-for-mutex-algorithm-3)) + (sb-ext:define-load-time-global *grab-mutex-calls-performed* 0) + ;; Like futex-wait but without garbage having to do with re-invoking + ;; a wake on account of async unwind while releasing the mutex. + (declaim (inline fast-futex-wait)) + (defun fast-futex-wait (word-addr oldval to-sec to-usec) + (with-alien ((%wait (function int unsigned + #+freebsd unsigned #-freebsd (unsigned 32) + long unsigned-long) + :extern "futex_wait")) + (alien-funcall %wait word-addr oldval to-sec to-usec))) + + (defun %wait-for-mutex-algorithm-2 (mutex) + (incf *grab-mutex-calls-performed*) + (let* ((mutex (sb-ext:truly-the mutex mutex)) + (c (sb-ext:cas val 0 1))) ; available -> taken + (unless (= c 0) ; Got it right off the bat? + (loop + ;; Mark it as contested, and sleep, unless it is now in state 0. + (when (or (eql c 2) (/= 0 (sb-ext:cas val 1 2))) + (with-pinned-objects (mutex) + (fast-futex-wait (mutex-state-address mutex) 2 -1 0))) + ;; Try to get it, still marking it as contested. + (when (= 0 (setq c (sb-ext:cas val 0 2))) (return)))))) ; win + (defun %wait-for-mutex-algorithm-3 (mutex) + (incf *grab-mutex-calls-performed*) + (let* ((mutex (sb-ext:truly-the mutex mutex)) + (c (sb-ext:cas val 0 1))) ; available -> taken + (unless (= c 0) ; Got it right off the bat? + (unless (= c 2) + (setq c (%raw-instance-xchg/word mutex (get-dsd-index mutex state) 2))) + (loop while (/= c 0) + do (with-pinned-objects (mutex) + (fast-futex-wait (mutex-state-address mutex) 2 -1 0)) + (setq c (%raw-instance-xchg/word mutex (get-dsd-index mutex state) 2)))))) + + (defun wait-for-mutex-algorithm-2 (mutex) + (declare (inline %wait-for-mutex-algorithm-2)) + (let ((mutex (sb-ext:truly-the mutex mutex))) + (%wait-for-mutex-algorithm-2 mutex) + (setf (mutex-%owner mutex) *current-thread*))) + ;; The improvement with algorithm 3 is fairly negligible. + ;; Code size is a little less. More improvement comes from doing the + ;; partial-inline algorithms which perform one CAS without a function call. + (defun wait-for-mutex-algorithm-3 (mutex) + (declare (inline %wait-for-mutex-algorithm-3)) + (let ((mutex (sb-ext:truly-the mutex mutex))) + (%wait-for-mutex-algorithm-3 mutex) + (setf (mutex-%owner mutex) *current-thread*))) + (defmacro wait-for-mutex-2-partial-inline (mutex) + `(let ((m ,mutex)) + (or (= (sb-ext:cas (mutex-state m) 0 1) 0) (%wait-for-mutex-algorithm-2 m)) + (setf (mutex-%owner m) *current-thread*))) + (defmacro wait-for-mutex-3-partial-inline (mutex) + `(let ((m ,mutex)) + (or (= (sb-ext:cas (mutex-state m) 0 1) 0) (%wait-for-mutex-algorithm-3 m)) + (setf (mutex-%owner m) *current-thread*))) + ;; This is like RELEASE-MUTEX but without keyword arg parsing + ;; and all the different error modes. + (export 'fast-release-mutex) + (defun fast-release-mutex (mutex) + (let ((mutex (sb-ext:truly-the mutex mutex))) + (setf (mutex-%owner mutex) nil) + (unless (eql (sb-ext:atomic-decf (mutex-state mutex) 1) 1) + (setf (mutex-state mutex) 0) + (with-pinned-objects (mutex) + (futex-wake (mutex-state-address mutex) 1)))))) + #+sb-thread (defun %wait-for-mutex (mutex self timeout to-sec to-usec stop-sec stop-usec deadlinep) (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) @@ -922,7 +979,7 @@ #-sb-futex protected) -(declaim (inline %condition-wait)) +(declaim (sb-ext:maybe-inline %condition-wait)) (defun %condition-wait (queue mutex timeout to-sec to-usec stop-sec stop-usec deadlinep) #-sb-thread @@ -1037,7 +1094,6 @@ ;; The only case we return normally without re-acquiring ;; the mutex is when there is a :TIMEOUT that runs out. (bug "%CONDITION-WAIT: invalid status on normal return: ~S" status)))))) -(declaim (notinline %condition-wait)) (declaim (ftype (sfunction (waitqueue mutex &key (:timeout (or null (real 0)))) boolean) condition-wait)) (defun condition-wait (queue mutex &key timeout) @@ -1314,8 +1370,6 @@ (interactive-threads-queue (make-waitqueue :name "session"))) (declaim (sb-ext:freeze-type session)) -(defvar *session* nil) - ;;; The debugger itself tries to acquire the session lock, don't let ;;; funny situations (like getting a sigint while holding the session ;;; lock) occur. At the same time we need to allow interrupts while @@ -1347,11 +1401,6 @@ (make-session :threads (list thread) :interactive-threads (list thread))) -(defun init-job-control () - (/show0 "Entering INIT-JOB-CONTROL") - (setf *session* (new-session *current-thread*)) - (/show0 "Exiting INIT-JOB-CONTROL")) - (defun %delete-thread-from-session (thread &aux (session *session*)) (with-session-lock (session) ;; One of two things about THREAD must be true, either: @@ -1389,25 +1438,33 @@ `((let ((,c-thread (thread-primitive-thread ,thread))) ,@body)) body))) +(sb-ext:define-load-time-global *sprof-data* nil) +#+allocator-metrics +(sb-ext:define-load-time-global *allocator-metrics* nil) + #+sb-thread (progn ;;; Remove thread from its session, if it has one, and from *all-threads*. ;;; Also clobber the pointer to the primitive thread ;;; which makes THREAD-ALIVE-P return false hereafter. (defmacro handle-thread-exit () - '(progn - (/show0 "HANDLING THREAD EXIT") - (when *exit-in-progress* - (%exit)) - ;; Lisp-side cleanup - (let* ((thread *current-thread*) + '(let* ((thread *current-thread*) ;; use the "funny fixnum" representation (c-thread (%make-lisp-obj (thread-primitive-thread thread))) (sem (thread-semaphore thread))) + ;; System threads exit peacefully when asked, and they don't bother anyone. + ;; They must not participate in shutting other threads down. + (when (and *exit-in-progress* (not (thread-ephemeral-p thread))) + (%exit)) ;; This AVER failed when I messed up deletion from *STARTING-THREADS*. ;; That in turn caused a failure in GC because a fixnum is not a legal value ;; for the startup info when observed by GC. #+pauseless-threadstart (aver (not (memq thread *starting-threads*))) + ;; If collecting allocator metrics, transfer them to the global list + ;; so that we can summarize over exited threads. + #+allocator-metrics + (let ((metrics (cons (thread-name thread) (allocator-histogram)))) + (sb-ext:atomic-push metrics *allocator-metrics*)) ;; Stash the primitive thread SAP for reuse, but clobber the PRIMITIVE-THREAD ;; slot which makes ALIVE-P return NIL. ;; A minor TODO: can this lock acquire/release be moved to where we actually @@ -1418,7 +1475,26 @@ (with-deathlok (thread) (when sem ; ordinary lisp thread, not FOREIGN-THREAD (setf (thread-startup-info thread) c-thread)) - (setf (thread-primitive-thread thread) 0) + ;; Accept no further interruptions. Other threads can't add new ones to the queue + ;; as doing so requires grabbing the per-thread mutex which we currently own. + ;; Deferrable signals are masked at this point, but it is best to tidy up + ;; any stray data such as captured closure values. + (setf (thread-interruptions thread) nil + (thread-primitive-thread thread) 0) + (setf (sap-ref-8 (current-thread-sap) ; state_word.sprof_enable + (1+ (ash sb-vm:thread-state-word-slot sb-vm:word-shift))) + 0) + ;; Take ownership of our statistical profiling data and transfer the results to + ;; the global pool. This doesn't need to synchronize with the signal handler, + ;; which is effectively disabled now, but does synchronize via the interruptions + ;; mutex with any other thread trying to read this thread's data. + (let ((sprof-data (sb-vm::current-thread-offset-sap sb-vm:thread-sprof-data-slot))) + (unless (= (sap-int sprof-data) 0) + (setf (sap-ref-word (descriptor-sap c-thread) + (ash sb-vm:thread-sprof-data-slot sb-vm:word-shift)) + 0) + ;; Operation on the global list must be atomic. + (sb-ext:atomic-push (cons sprof-data thread) *sprof-data*))) (barrier (:write))) ;; After making the thread dead, remove from session. If this were done first, ;; we'd just waste time moving the thread into SESSION-THREADS (if it wasn't there) @@ -1457,7 +1533,7 @@ ;; our own kind of semaphore, we simply signal it using an arbitrarily huge count. ;; See the comment in 'thread-structs.lisp' about why this isn't CONDITION-BROADCAST ;; on a condition var. (Good luck trying to make this many threads) - (signal-semaphore sem 1000000))))) + (signal-semaphore sem 1000000)))) ;;; The "funny fixnum" address format would do no good - AVL-FIND and AVL-DELETE ;;; expect normal happy lisp integers, even if a bignum. @@ -1779,7 +1855,9 @@ (with-pinned-objects (mask) (sb-unix::pthread-sigmask sb-unix::SIG_SETMASK mask nil)) ;; Otherwise just do the usual thing - (sb-unix::unblock-deferrable-signals))))) + (sb-unix::pthread-sigmask sb-unix::SIG_UNBLOCK + (foreign-symbol-sap "thread_start_sigset" t) + nil))))) ;; notinline keeps array off the call stack by getting it out of the curent frame (declare (notinline unmask-signals)) ;; Signals other than stop-for-GC are masked. The WITH/WITHOUT noise is @@ -1822,6 +1900,14 @@ (without-interrupts (unwind-protect (with-local-interrupts + ;; New threads should start with SIGPROF blocked if profiling is enabled + ;; on just a subset of threads. Ideally we'd add to the blocked mask + ;; right now, but it suffices to just leave the enabling bit at its default + ;; of 0; at worst, one undesired signal would be received. + (when (eq *profiled-threads* :all) + (setf (sap-ref-8 (current-thread-sap) ; state_word.sprof_enable + (1+ (ash sb-vm:thread-state-word-slot sb-vm:word-shift))) + 1)) (unmask-signals) (let ((list (multiple-value-list @@ -1830,20 +1916,23 @@ (sb-c::inspect-unwinding (apply-real-function) #'sb-di::catch-runaway-unwind)) - (when *exit-in-progress* + (when (and *exit-in-progress* + (not (thread-ephemeral-p *current-thread*))) (sb-impl::call-exit-hooks)))))) #+sb-safepoint (sb-kernel::gc-safepoint) (setf (thread-result *current-thread*) list))) ;; we're going down, can't handle interrupts ;; sanely anymore. gc remains enabled. - (block-deferrable-signals) + (with-alien ((%block (function int system-area-pointer) + :extern "block_deferrable_signals")) + (alien-funcall %block (int-sap 0))) ;; we don't want to run interrupts in a dead ;; thread when we leave without-interrupts. ;; this potentially causes important ;; interupts to be lost: sigint comes to ;; mind. (setq *interrupt-pending* nil) - #+sb-thruption + #+sb-safepoint (setq *thruption-pending* nil) (handle-thread-exit))))))) ;; this returns to C, so return a single value @@ -1873,9 +1962,12 @@ ;;; System-internal use only #+sb-thread -(defun make-ephemeral-thread (name function arguments) - (start-thread (%make-thread name t (make-semaphore :name name)) - function arguments)) +(defun make-system-thread (name function arguments symbol) + (let ((thread (%make-thread name t (make-semaphore :name name)))) + (when symbol + (aver (not (symbol-value symbol))) + (set symbol thread)) + (start-thread thread function arguments))) ;;; This is the faster variant of RUN-THREAD that does not wait for the new ;;; thread to start executing before returning. @@ -1919,7 +2011,7 @@ ;; before the various interrupt-related special vars are set up. ;; Preserve the current mask into SAVED-SIGMASK and CHILD-SIGMASK. (sb-unix::pthread-sigmask sb-unix::SIG_BLOCK - (foreign-symbol-sap "deferrable_sigset" t) + (foreign-symbol-sap "thread_start_sigset" t) saved-sigmask) (replace child-sigmask saved-sigmask) ;; Ensure that timers and interrupt-thread are directed only to "user" threads. @@ -2105,32 +2197,12 @@ (defun destroy-thread (thread) (terminate-thread thread)) -#-sb-xc-host (declaim (sb-ext:deprecated :late ("SBCL" "1.2.15") (function destroy-thread :replacement terminate-thread))) -;;; raise() is defined to send the signal to pthread_self() if multithreaded. -(defmacro raise (signal) - `(alien-funcall (extern-alien "raise" (function int int)) ,signal)) - -;;; A macro, because OS-THREAD is a WORD which could cause boxing if passed -;;; to a function. -(defmacro pthread-kill (os-thread signal) - (declare (ignorable os-thread)) - ;; If no threads, pthread_kill() won't exist since we didn't link with -lpthread. - ;; And raise() - as we use it - can't fail, so just ignore the result. - ;; (The signal number is always SIGURG or SIGINT, and the process is obviously not dead) - ;; This isn't used on win32 so we don't need to change the symbol to sb_pthr_kill there. - #-sb-thread `(raise ,signal) - #+sb-thread - `(unless (= 0 (alien-funcall (extern-alien "pthread_kill" - (function int unsigned int)) - ,os-thread ,signal)) - (error "pthread_kill() failed"))) - ;;; Called from the signal handler. -#-(or sb-thruption win32) +#-(or sb-safepoint win32) (defun run-interruption () (let ((interruption (with-deathlok (*current-thread*) (pop (thread-interruptions *current-thread*))))) @@ -2139,13 +2211,13 @@ ;; OS's point of view the signal we are in the handler for is no ;; longer pending, so the signal will not be lost. (when (thread-interruptions *current-thread*) - (raise sb-unix:sigurg)) + (sb-unix:raise sb-unix:sigurg)) ;; FIXME: does this really respect the promised ordering of interruptions? ;; It looks backwards to raise first and run the popped function second. (when interruption (funcall interruption)))) -#+sb-thruption +#+sb-safepoint (defun run-interruption (*current-internal-error-context*) (in-interruption () ;the non-thruption code does this in the signal handler (let ((interruption (with-deathlok (*current-thread*) @@ -2174,18 +2246,13 @@ #+linux (defun thread-os-tid (thread) (declare (ignorable thread)) - #+sb-thread (if (eq *current-thread* thread) (my-kernel-thread-id) (with-deathlok (thread c-thread) (unless (= c-thread 0) (sap-ref-32 (int-sap c-thread) (+ (ash sb-vm::thread-os-kernel-tid-slot sb-vm:word-shift) - #+(and 64-bit big-endian) 4))))) - ;; The man page for gettid() says - ;; "In a single-threaded process, the thread ID is equal to the process ID" - ;; It probably would be fine to return 0 here; nothing internal uses the value. - #-sb-thread (sb-unix:unix-getpid)) + #+(and 64-bit big-endian) 4)))))) (defun interrupt-thread (thread function) (declare (ignorable thread)) @@ -2241,42 +2308,40 @@ (interrupt-thread thread #'break) Short version: be careful out there." - (macrolet ((enqueue () - ;; Append to the end of the interruptions queue. It's - ;; O(N), but it does not hurt to slow interruptors down a - ;; bit when the queue gets long. - `(setf (thread-interruptions thread) - (append (thread-interruptions thread) - (list (lambda () - (barrier (:memory)) ; why??? - (without-interrupts - (allow-with-interrupts - (funcall function))))))))) ;; POSIX says: ;; "If an application attempts to use a thread ID whose lifetime has ended, ;; the behavior is undefined." ;; so we use the death lock to keep the thread alive, unless it already isn't. ;; (when (with-deathlok (thread c-thread) - (declare (ignorable c-thread)) ;; Return T if couldn't interrupt. - (cond #+sb-thread ((eql c-thread 0) t) - (t - (enqueue) - ;; We use SIGURG because it satisfies a lot of requirements that - ;; other people have thought about more than we have. - ;; See https://golang.org/src/runtime/signal_unix.go where they describe - ;; which signal works best for their sigPreempt. - ;; It's basically the same use-case as here. - #-sb-safepoint (pthread-kill (thread-os-thread thread) sb-unix:sigurg) - #+sb-safepoint - (with-alien ((wake (function void system-area-pointer) - :extern "wake_thread")) - (with-pinned-objects (thread) - (alien-funcall wake (sap+ (int-sap (get-lisp-obj-address thread)) - (- sb-vm:instance-pointer-lowtag))))) - nil))) - (error 'interrupt-thread-error :thread thread)))) + (cond ((eql c-thread 0) t) + (t (%interrupt-thread thread function) nil))) + (error 'interrupt-thread-error :thread thread))) + +(defun %interrupt-thread (thread function) + ;; Append to the end of the interruptions queue. It's + ;; O(N), but it does not hurt to slow interruptors down a + ;; bit when the queue gets long. + (setf (thread-interruptions thread) + (append (thread-interruptions thread) + ;; It seems to me that this junk should be in RUN-INTERRUPTION, + ;; but it doesn't really matter where it goes. + (list (lambda () + (barrier (:memory)) ; why??? + (without-interrupts (allow-with-interrupts (funcall function))))))) + ;; We use SIGURG because it satisfies a lot of requirements that + ;; other people have thought about more than we have. + ;; See https://golang.org/src/runtime/signal_unix.go where they describe + ;; which signal works best for their sigPreempt. + ;; It's basically the same use-case as here. + #-sb-safepoint (sb-unix:pthread-kill (thread-os-thread thread) sb-unix:sigurg) + #+sb-safepoint + (with-alien ((wake (function void system-area-pointer) :extern "wake_thread")) + (with-pinned-objects (thread) + (alien-funcall wake (sap+ (int-sap (get-lisp-obj-address thread)) + (- sb-vm:instance-pointer-lowtag))))) + nil) (defun terminate-thread (thread) "Terminate the thread identified by THREAD, by interrupting it and @@ -2466,8 +2531,6 @@ ;; I wonder how to to prevent user code from doing this, but it isn't a new problem per se. ;; Perhaps this should be symbol-macro with a vop behind it and no setf expander. (setf *current-thread* thread) - ;; This is made thread-local by "src/runtime/genesis/thread-init.inc" - (setf sb-vm:*alloc-signal* *default-alloc-signal*) thread) (eval-when (:compile-toplevel) @@ -2498,43 +2561,50 @@ ;;;; Diagnostic tool -#+(and sb-thread sb-devel) +#+sb-devel (defun dump-thread () - (let* ((primobj (find 'sb-vm::thread sb-vm:*primitive-objects* - :key #'sb-vm::primitive-object-name)) + (let* ((primobj (sb-vm::primitive-object 'sb-vm::thread)) (slots (sb-vm::primitive-object-slots primobj)) (sap (current-thread-sap)) (thread-obj-len (sb-vm::primitive-object-length primobj)) (names (make-array thread-obj-len :initial-element ""))) - (dolist (slot slots) - (setf (aref names (sb-vm::slot-offset slot)) (sb-vm::slot-name slot))) + (loop for slot across slots + do + (setf (aref names (sb-vm::slot-offset slot)) (sb-vm::slot-name slot))) (flet ((safely-read (sap offset) (let ((word (sap-ref-word sap offset))) (cond ((= word sb-vm:no-tls-value-marker-widetag) :no-tls-value) ((= word sb-vm:unbound-marker-widetag) :unbound) (t (sap-ref-lispobj sap offset))))) - (show (tlsindex val) + (show (sym val) (let ((*print-right-margin* 128) (*print-lines* 4)) (format t " ~3d ~30a : ~s~%" - (ash tlsindex (- sb-vm:word-shift)) + #+sb-thread (ash sym (- sb-vm:word-shift)) + #-sb-thread 0 ;; FIND-SYMBOL-FROM-TLS-INDEX uses MAP-ALLOCATED-OBJECTS ;; which is not defined during cross-compilation. - (funcall 'sb-impl::find-symbol-from-tls-index tlsindex) + #+sb-thread (funcall 'sb-impl::find-symbol-from-tls-index sym) + #-sb-thread sym val)))) (format t "~&TLS: (base=~x)~%" (sap-int sap)) (loop for tlsindex from sb-vm:n-word-bytes below - (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits) + #+sb-thread (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits) + #-sb-thread (ash thread-obj-len sb-vm:word-shift) by sb-vm:n-word-bytes - do (let ((thread-slot-name - (if (< tlsindex (ash thread-obj-len sb-vm:word-shift)) + do + (unless (<= sb-vm::thread-obj-size-histo-slot + (ash tlsindex (- sb-vm:word-shift)) + (+ sb-vm::thread-obj-size-histo-slot (1- sb-vm:n-word-bits))) + (let ((thread-slot-name + (if (< tlsindex (ash thread-obj-len sb-vm:word-shift)) (aref names (ash tlsindex (- sb-vm:word-shift)))))) (if (and thread-slot-name (neq thread-slot-name 'sb-vm::lisp-thread)) (format t " ~3d ~30a : #x~x~%" (ash tlsindex (- sb-vm:word-shift)) thread-slot-name (sap-ref-word sap tlsindex)) (let ((val (safely-read sap tlsindex))) (unless (eq val :no-tls-value) - (show tlsindex val)))))) + (show tlsindex val))))))) (let ((from (descriptor-sap sb-vm:*binding-stack-start*)) (to (binding-stack-pointer-sap))) (format t "~%Binding stack: (depth ~d)~%" @@ -2542,6 +2612,83 @@ (loop (when (sap>= from to) (return)) (let ((val (safely-read from 0)) - (tlsindex (sap-ref-word from sb-vm:n-word-bytes))) - (show tlsindex val)) + (sym #+sb-thread (sap-ref-word from sb-vm:n-word-bytes) ; a TLS index + #-sb-thread (sap-ref-lispobj from sb-vm:n-word-bytes))) + (show sym val)) (setq from (sap+ from (* sb-vm:binding-size sb-vm:n-word-bytes)))))))) + +#+allocator-metrics +(macrolet ((histogram-value (c-thread index) + `(sap-ref-word (int-sap ,c-thread) + (ash (+ sb-vm::thread-obj-size-histo-slot ,index) + sb-vm:word-shift))) + (metric (c-thread slot) + `(sap-ref-word (int-sap ,c-thread) + (ash ,slot sb-vm:word-shift)))) +(export '(print-allocator-histogram reset-allocator-histogram)) +(defun allocator-histogram (&optional (thread *current-thread*)) + (if (eq thread :all) + (labels ((vector-sum (a b) + (let ((result (make-array (max (length a) (length b)) + :element-type 'fixnum))) + (dotimes (i (length result) result) + (setf (aref result i) + (+ (if (< i (length a)) (aref a i) 0) + (if (< i (length b)) (aref b i) 0)))))) + (sum (a b) + (cond ((null a) b) + ((null b) a) + (t (cons (vector-sum (car a) (car b)) + (mapcar #'+ (cdr a) (cdr b))))))) + (reduce #'sum + ;; what about the finalizer thread? + (mapcar 'allocator-histogram (list-all-threads)))) + (with-deathlok (thread c-thread) + (unless (= c-thread 0) + (dx-let ((a (make-array (+ sb-vm::histogram-small-bins sb-vm:n-word-bits) + :element-type 'fixnum))) + (dotimes (i (length a)) + (setf (aref a i) (histogram-value c-thread i))) + (list (subseq a 0 (1+ (or (position 0 a :from-end t :test #'/=) -1))) + (metric c-thread sb-vm::thread-tot-bytes-alloc-boxed-slot) + (metric c-thread sb-vm::thread-tot-bytes-alloc-unboxed-slot) + (metric c-thread sb-vm::thread-slow-path-allocs-slot) + (metric c-thread sb-vm::thread-et-allocator-mutex-acq-slot) + (metric c-thread sb-vm::thread-et-find-freeish-page-slot) + (metric c-thread sb-vm::thread-et-bzeroing-slot))))))) + +(defun reset-allocator-histogram (&optional (thread *current-thread*)) + (with-deathlok (thread c-thread) + (unless (= c-thread 0) + (setf (metric c-thread sb-vm::thread-tot-bytes-alloc-boxed-slot) 0 + (metric c-thread sb-vm::thread-tot-bytes-alloc-unboxed-slot) 0 + (metric c-thread sb-vm::thread-slow-path-allocs-slot) 0) + (dotimes (i (+ sb-vm::histogram-small-bins sb-vm:n-word-bits)) + (setf (histogram-value c-thread i) 0))))) + +(defun print-allocator-histogram (&optional (thread *current-thread*)) + (destructuring-bind (bins tot-bytes-boxed tot-bytes-unboxed n-slow-path lock find clear) + (allocator-histogram thread) + (let ((total-objects (reduce #'+ bins)) + (cumulative 0)) + (format t "~& Size Count Cum%~%") + (loop for index from 0 + for count across bins + for size-exact-p = (< index sb-vm::histogram-small-bins) + for size = (if size-exact-p + (* (1+ index) 2 sb-vm:n-word-bytes) + (ash 1 (+ (- index sb-vm::histogram-small-bins) 10))) + do + (incf cumulative count) + (format t "~& ~10@a : ~8d ~6,2,2f~%" + (cond (size-exact-p size) + ((< size 1048576) (format nil "< ~d" size)) + (t (format nil "< 2^~d" (1- (integer-length size))))) + count (/ cumulative total-objects)) + (setq size (* size 2))) + (when (plusp total-objects) + (format t "Total: ~D+~D bytes, ~D objects, ~,2,2f% fast path~%" + tot-bytes-boxed tot-bytes-unboxed total-objects + (/ (- total-objects n-slow-path) total-objects))) + (format t "Times (sec): lock=~,,-9f find=~,,-9f clear=~,,-9f~%" + lock find clear))))) diff -Nru sbcl-2.1.1/src/code/target-unicode.lisp sbcl-2.1.11/src/code/target-unicode.lisp --- sbcl-2.1.1/src/code/target-unicode.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/target-unicode.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,60 +11,42 @@ (in-package "SB-UNICODE") -(declaim (type simple-vector **special-numerics**)) -(sb-ext:define-load-time-global **special-numerics** - #.(sb-cold:read-from-file "output/numerics.lisp-expr")) - -(macrolet ((unicode-property-init () - (let ((confusable-sets - (sb-cold:read-from-file "output/confusables.lisp-expr")) - (bidi-mirroring-list - (sb-cold:read-from-file "output/bidi-mirrors.lisp-expr"))) - `(progn - (sb-ext:define-load-time-global **proplist-properties** nil) - (sb-ext:define-load-time-global **confusables** - ',confusable-sets) - (sb-ext:define-load-time-global **bidi-mirroring-glyphs** - ',bidi-mirroring-list) - (defun !unicode-properties-cold-init () - ;; - (let ((hash (make-hash-table)) ; keys are symbols - (list ',(sb-cold:read-from-file - "output/misc-properties.lisp-expr"))) - (setq **proplist-properties** hash) - (loop for (symbol ranges) on list by #'cddr - do (setf (gethash symbol hash) - (coerce ranges '(vector (unsigned-byte 32)))))) - ;; - (let* ((data ',confusable-sets) - (hash (make-hash-table :test #'eq - #+sb-unicode :size #+sb-unicode (length data)))) - (loop for (source . target) in data - when (and #-sb-unicode - (< source char-code-limit)) - do (flet ((minimize (x) - (case (length x) - (1 - (elt x 0)) - (2 - (pack-3-codepoints (elt x 0) (elt x 1))) - (3 - (pack-3-codepoints (elt x 0) (elt x 1) (elt x 2))) - (t - (logically-readonlyize - (possibly-base-stringize - (map 'string #'code-char x))))))) - - (setf (gethash (code-char source) hash) - (minimize target)))) - (setf **confusables** hash)) - ;; - (let* ((list ',bidi-mirroring-list) - (hash (make-hash-table :test #'eq :size (length list)))) - (loop for (k v) in list do - (setf (gethash k hash) v)) - (setf **bidi-mirroring-glyphs** hash))))))) - (unicode-property-init)) +(defconstant-eqx +special-numerics+ + #.(sb-cold:read-from-file "output/numerics.lisp-expr") + #'equalp) + +(sb-ext:define-load-time-global **proplist-properties** + (let* ((list '#.(sb-cold:read-from-file "output/misc-properties.lisp-expr")) + (hash (make-hash-table :size (length list)))) + (loop for (symbol ranges) on list by #'cddr + do (setf (gethash symbol hash) + (coerce ranges '(vector (unsigned-byte 32))))) + hash)) + +(sb-ext:define-load-time-global **confusables** + (let* ((data '#.(sb-cold:read-from-file "output/confusables.lisp-expr")) + (hash (make-hash-table :test #'eq #+sb-unicode :size #+sb-unicode (length data)))) + (loop for (source . target) in data + when (and #-sb-unicode (< source char-code-limit)) + do (flet ((minimize (x) + (case (length x) + (1 + (elt x 0)) + (2 + (pack-3-codepoints (elt x 0) (elt x 1))) + (3 + (pack-3-codepoints (elt x 0) (elt x 1) (elt x 2))) + (t + (logically-readonlyize + (possibly-base-stringize (map 'string #'code-char x))))))) + (setf (gethash (code-char source) hash) (minimize target)))) + hash)) + +(sb-ext:define-load-time-global **bidi-mirroring-glyphs** + (let* ((list '#.(sb-cold:read-from-file "output/bidi-mirrors.lisp-expr")) + (hash (make-hash-table :test #'eq :size (length list)))) + (loop for (k v) in list do (setf (gethash k hash) v)) + hash)) ;;; Unicode property access (defun ordered-ranges-member (item vector) @@ -143,12 +125,12 @@ :Bn (svref-or-null #.(read-ucd-constant '*bidi-classes*) - (aref **character-misc-database** (1+ (misc-index character)))))) + (aref +character-misc-database+ (1+ (misc-index character)))))) (declaim (inline combining-class)) (defun combining-class (character) "Returns the canonical combining class (CCC) of CHARACTER" - (aref **character-misc-database** (+ 2 (misc-index character)))) + (aref +character-misc-database+ (+ 2 (misc-index character)))) (defun decimal-value (character) "Returns the decimal digit value associated with CHARACTER or NIL if @@ -168,7 +150,7 @@ but there are characters (such as digits of number systems without a 0 value) that have a digit value but no decimal digit value" (let ((%digit (clear-flag 6 - (aref **character-misc-database** + (aref +character-misc-database+ (+ 3 (misc-index character)))))) (if (< %digit 10) %digit nil))) @@ -176,14 +158,13 @@ "Returns the numeric value of CHARACTER or NIL if there is no such value. Numeric value is the most general of the Unicode numeric properties. The only constraint on the numeric value is that it be a rational number." - (or (double-vector-binary-search (char-code character) - **special-numerics**) + (or (double-vector-binary-search (char-code character) +special-numerics+) (digit-value character))) (defun mirrored-p (character) "Returns T if CHARACTER needs to be mirrored in bidirectional text. Otherwise, returns NIL." - (logbitp 5 (aref **character-misc-database** + (logbitp 5 (aref +character-misc-database+ (+ 5 (misc-index character))))) (defun bidi-mirroring-glyph (character) @@ -199,14 +180,14 @@ :W (Wide), :F (Fullwidth), or :NA (Not applicable)" (svref-or-null #.(read-ucd-constant '*east-asian-widths*) (ldb (byte 3 0) - (aref **character-misc-database** + (aref +character-misc-database+ (+ 5 (misc-index character)))))) (defun script (character) "Returns the Script property of CHARACTER as a keyword. If CHARACTER does not have a known script, returns :UNKNOWN" (svref-or-null #.(read-ucd-constant '*scripts*) - (aref **character-misc-database** (+ 6 (misc-index character))))) + (aref +character-misc-database+ (+ 6 (misc-index character))))) (defun char-block (character) "Returns the Unicode block in which CHARACTER resides as a keyword. @@ -227,15 +208,15 @@ is only included for backwards compatibility." (let* ((char-code (char-code character)) (h-code (double-vector-binary-search char-code - **unicode-1-char-name-database**))) + +unicode-1-char-name-database+))) (when h-code - (huffman-decode h-code **unicode-character-name-huffman-tree**)))) + (huffman-decode h-code +unicode-character-name-huffman-tree+)))) (defun age (character) "Returns the version of Unicode in which CHARACTER was assigned as a pair of values, both integers, representing the major and minor version respectively. If CHARACTER is not assigned in Unicode, returns NIL for both values." - (let* ((value (aref **character-misc-database** (+ 8 (misc-index character)))) + (let* ((value (aref +character-misc-database+ (+ 8 (misc-index character)))) (major (ash value -3)) (minor (ldb (byte 3 0) value))) (if (zerop value) (values nil nil) (values major minor)))) @@ -269,7 +250,7 @@ (when (and resolve (not character)) (return-from line-break-class :nil)) (let ((raw-class (svref-or-null #.(read-ucd-constant '*line-break-classes*) - (aref **character-misc-database** (+ 7 (misc-index character))))) + (aref +character-misc-database+ (+ 7 (misc-index character))))) (syllable-type (hangul-syllable-type character))) (when syllable-type (setf raw-class @@ -367,7 +348,7 @@ ;;; Implements UAX#15: Normalization Forms (declaim (inline char-decomposition-info)) (defun char-decomposition-info (char) - (let ((value (aref **character-misc-database** + (let ((value (aref +character-misc-database+ (+ 4 (misc-index char))))) (values (clear-flag 7 value) (logbitp 7 value)))) @@ -376,10 +357,10 @@ ;; Caller should have gotten length from char-decomposition-info (let* ((cp (char-code char)) (cp-high (ash cp -8)) - (decompositions **character-decompositions**) - (high-page (aref **character-high-pages** cp-high)) + (decompositions +character-decompositions+) + (high-page (aref +character-high-pages+ cp-high)) (index (unless (logbitp 15 high-page) ;; Hangul syllable - (aref **character-low-pages** + (aref +character-low-pages+ (+ 1 (* 2 (+ (ldb (byte 8 0) cp) (ash high-page 8)))))))) (cond ((= length 1) (funcall callback (code-char (aref decompositions index)))) @@ -582,7 +563,7 @@ (defun has-case-p (char) ;; Bit 6 is the Unicode case flag, as opposed to the Common Lisp one - (logbitp 6 (aref **character-misc-database** (+ 5 (misc-index char))))) + (logbitp 6 (aref +character-misc-database+ (+ 5 (misc-index char))))) (defun char-uppercase (char) (if (has-case-p char) diff -Nru sbcl-2.1.1/src/code/thread-structs.lisp sbcl-2.1.11/src/code/thread-structs.lisp --- sbcl-2.1.1/src/code/thread-structs.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/thread-structs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -62,6 +62,9 @@ (declaim (sb-ext:freeze-type waitqueue semaphore)) +(sb-ext:define-load-time-global *profiled-threads* :all) +(declaim (type (or (eql :all) list) *profiled-threads*)) + (sb-xc:defstruct (thread (:constructor %make-thread (name %ephemeral-p semaphore)) (:copier nil)) "Thread type. Do not rely on threads being structs as it may change @@ -155,14 +158,6 @@ "Type of native threads which are attached to the runtime as Lisp threads temporarily.") -#+(and sb-safepoint-strictly (not win32)) -(sb-xc:defstruct (signal-handling-thread - (:copier nil) - (:include foreign-thread) - (:conc-name "THREAD-")) - "Asynchronous signal handling thread." - (signal-number nil :type integer)) - (declaim (sb-ext:freeze-type mutex thread)) #-sb-xc-host (progn diff -Nru sbcl-2.1.1/src/code/timer.lisp sbcl-2.1.11/src/code/timer.lisp --- sbcl-2.1.1/src/code/timer.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/timer.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -344,13 +344,10 @@ ;;; win32 waitable timers using a timerfd-like portability layer in ;;; the runtime. -#+sb-wtimer -(define-alien-type wtimer - #+win32 system-area-pointer ;HANDLE, but that's not defined yet - #+sunos system-area-pointer ;struct os_wtimer * - #+(or android linux bsd) int) +#+win32 +(define-alien-type wtimer system-area-pointer) ;HANDLE, but that's not defined yet -#+sb-wtimer +#+win32 (progn (define-alien-routine "os_create_wtimer" wtimer) (define-alien-routine "os_wait_for_wtimer" int (wt wtimer)) @@ -370,7 +367,7 @@ (prog1 (setf *waitable-timer-handle* (os-create-wtimer)) (setf *timer-thread* - (sb-thread::make-ephemeral-thread + (sb-thread::make-system-thread "System timer watchdog thread" (lambda () (loop while @@ -378,7 +375,7 @@ (os-wait-for-wtimer *waitable-timer-handle*)) *waitable-timer-handle*) doing (run-expired-timers))) - nil))))) + nil nil))))) (defun itimer-emulation-deinit () (with-scheduler-lock () @@ -411,7 +408,7 @@ (values 0 min-nsec) (values s u)))))) -#-(or sb-wtimer win32) +#+unix (progn (defun %set-system-timer (sec nsec) (sb-unix:unix-setitimer :real 0 0 sec (ceiling nsec 1000))) diff -Nru sbcl-2.1.1/src/code/toplevel.lisp sbcl-2.1.11/src/code/toplevel.lisp --- sbcl-2.1.1/src/code/toplevel.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/toplevel.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -132,11 +132,11 @@ ;;; cancelation points (system and C library calls) which check for cancelation, ;;; perform whatever cleanups were pushed by pthread_cleanup_push() and then stop. ;;; -;;; P.S. To see that #+sb-thruption is no magic fix - suppose you have a stack +;;; P.S. To see that #+sb-safepoint is no magic fix - suppose you have a stack ;;; with Lisp -> C -> -> Lisp where C acquired a resource and the currently ;;; top-of-stack Lisp function took a safepoint trap. It would be fine if all it ;;; wanted to do was GC, but is not safe in general. -;;; Hence #+sb-thruption paints a dangerously attractive veneer over an unsafe +;;; Hence #+sb-safepoint paints a dangerously attractive veneer over an unsafe ;;; concept, making it more subtly bad instead of very obviously bad. ;;; ;;; So this is a bad default. Bad bad bad. But it's backward-compatible. @@ -402,6 +402,13 @@ args) (exit :code 1)) + +(defvar *runtime-options* + #("--noinform" "--core" "--help" "--version" "--dynamic-space-size" + "--control-stack-size" "--tls" + "--debug-environment" "--disable-ldb" "--lose-on-corruption" + "--end-runtime-options" "--merge-core-pages" "--no-merge-core-pages")) + ;;; the default system top level function (defun toplevel-init () (/show0 "entering TOPLEVEL-INIT") @@ -497,6 +504,9 @@ ((string= option "--end-toplevel-options") (pop-option) (return)) + ((find option *runtime-options* :test #'string=) + (startup-error "C runtime option ~a in the middle of Lisp options." + option)) (t ;; Anything we don't recognize as a toplevel ;; option must be the start of user-level @@ -549,9 +559,9 @@ (pathname it)) :if-does-not-exist nil) (cond (stream - (dx-flet ((thunk () - (load-as-source stream :context kind))) - (sb-fasl::call-with-load-bindings #'thunk stream))) + (sb-fasl::call-with-load-bindings + (lambda (stream kind) (load-as-source stream :context kind)) + stream kind stream)) (specified-pathname (cerror "Ignore missing init file" "The specified ~A file ~A was not found." diff -Nru sbcl-2.1.1/src/code/type-class.lisp sbcl-2.1.11/src/code/type-class.lisp --- sbcl-2.1.1/src/code/type-class.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/type-class.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -42,31 +42,22 @@ (make-array 32 :element-type 'bit :initial-element 0))) #+sb-xc -(macrolet ((def () - (let ((classes (make-array 32 :initial-element nil)) - ;; A curiosity observed with CLISP: if GENERATOR-STATE is not bound - ;; to a variable, but instead inserted with read-time-eval - ;; as "#.(sb-xc:make-array ...)" then DUMP-VECTOR fails to find the - ;; array in SB-COLD::*ARRAY-TO-SPECIALIZATION* even though it's there. - ;; Somehow between the read-time-eval and macroexpansion of DEF, - ;; CLISP seems to copy the array. It's as if READ did not return the - ;; object produced by "#." and I can't imagine how that's legal, - ;; let alone possible. - (generator-state - (sb-xc:make-array 1 :element-type '(and fixnum unsigned-byte) - :initial-element 0))) +(macrolet ((def (name init-form) `(progn - (declaim (type (simple-array (and fixnum unsigned-byte) (1)) - *ctype-hash-state*) - (type (simple-vector 32) *type-classes*)) - ;; Strictly speaking these array are immutable, as with all literals - ;; appearing in code. We mutate them anyway. Avoiding that minor infraction - ;; would require FOPCOMPILE to emit the MAKE-ARRAY expression to be executed - ;; in genesis; which is more of a project than I want to tackle. - (!define-load-time-global *ctype-hash-state* ,generator-state) - (!define-load-time-global *type-classes* ,classes) - (!cold-init-forms (fill *type-classes* (make-type-class :name :bogus))))))) - (def)) + (define-load-time-global ,name ,init-form) + (!cold-init-forms (setq ,name ,init-form))))) + (declaim (type (simple-array (and fixnum unsigned-byte) (1)) + *ctype-hash-state*) + (type (simple-vector 32) *type-classes*) + (type fixnum *type-cache-nonce*)) + (def *ctype-hash-state* (make-array 1 :element-type '(and fixnum unsigned-byte) + :initial-element 0)) + (def *type-classes* (make-array 32 :initial-element nil)) + ;; This is for "observers" who want to know if type names have been added. + ;; Rather than registering listeners, they can detect changes by comparing + ;; their stored nonce to the current nonce. Additionally the observers + ;; can detect whether function definitions have occurred. + (def *type-cache-nonce* 0)) #-sb-xc-host (define-compiler-macro type-class-or-lose (&whole form name) @@ -265,6 +256,10 @@ ;; But it's consistent for genesis to treat it always as a raw slot. (%bits (missing-arg) :type sb-vm:word :read-only t)) +(defmethod print-object ((ctype ctype) stream) + (print-unreadable-object (ctype stream :type t) + (prin1 (type-specifier ctype) stream))) + ;;; take 27 low bits but exclude bits 20 and 21 ;;; [Our MASK-FIELD can't be folded, and I didn't feel like fixing that.] (defconstant +type-hash-mask+ @@ -364,16 +359,30 @@ (defmacro define-type-method ((class method &rest more-methods) lambda-list &body body) - (let ((name (symbolicate class "-" method "-TYPE-METHOD")) - (arg-restriction + (let* ((name (symbolicate class "-" method "-TYPE-METHOD")) + (arg-type (case class - (classoid 'classoid) - (number 'numeric-type) - (function 'fun-type) - (alien 'alien-type-type) - ;; hairy could reparse the specifier into anything - (hairy (if (eq method :simple-subtypep) t 'hairy-type)) - (t (symbolicate class "-TYPE"))))) + (classoid 'classoid) + (number 'numeric-type) + (function 'fun-type) + (alien 'alien-type-type) + (t (symbolicate class "-TYPE")))) + (first (car lambda-list)) + (second (cadr lambda-list)) + ;; make-host-1 verifies that type methods are invoked correctly, + ;; but afterwards we assume that they are + (operator #+sb-xc-host 'the #-sb-xc-host 'truly-the) + (rebind + (unless more-methods + (case method + ((:complex-subtypep-arg1 :unparse :negate :singleton-p) + `((,first (,operator ,arg-type ,first)))) + ((:complex-subtypep-arg2) + `((,first ,first) ; because there might be a DECLARE IGNORE on it + (,second (,operator ,arg-type ,second)))) + ((:simple-intersection2 :simple-union2 :simple-subtypep :simple-=) + `((,first (,operator ,arg-type ,first)) + (,second (,operator ,arg-type ,second)))))))) `(progn #+sb-xc-host (when (plusp (bit *type-class-was-inherited* (type-class-name->id ',class))) @@ -381,14 +390,7 @@ ;; both an ancestor and its descendants on some method. ;; Too bad for you- this throws the baby out with the bathwater. (error "Can't define-type-method for class ~s: already inherited" ',class)) - (defun ,name ,lambda-list - ,@(cond ((member method '(:unparse :negate :singleton-p)) - `((declare (type ,arg-restriction ,(car lambda-list))))) - ((and (member method '(:simple-intersection2 :simple-union2 - :simple-subtypep :simple-=)) - (not more-methods)) - `((declare (type ,arg-restriction ,(car lambda-list) ,(cadr lambda-list)))))) - ,@body) + (defun ,name ,lambda-list ,@(if rebind `((let ,rebind ,@body)) body)) (!cold-init-forms ,@(mapcar (lambda (method) `(setf (,(type-class-fun-slot method) @@ -422,16 +424,12 @@ (loop for name in type-class-fun-slots append `(,(keywordicate name) (,(type-class-fun-slot name) parent)))))))) + ;; Careful: type-classes are very complicated things to redefine. + ;; For the sake of parallelized make-host-1 we have to allow + ;; redefinition, but it has to be a no-op. #+sb-xc-host - `(progn - ;; Careful: type-classes are very complicated things to redefine. - ;; For the sake of parallelized make-host-1 we have to allow - ;; redefinition, but it has to be a no-op. - (unless (find ',name *type-classes* :key #'type-class-name) - (vector-push ,make-it *type-classes*)) - ;; I have no idea what compiler bug could be worked around by adding a form here, - ;; but this certainly achieves something, somehow. - #+host-quirks-cmu (print (aref *type-classes* (1- (length *type-classes*))))) + `(unless (find ',name *type-classes* :key #'type-class-name) + (vector-push ,make-it *type-classes*)) #+sb-xc (let ((type-class-index @@ -532,16 +530,40 @@ (funcall (the function method-fun) type1 type2) (values subtypep win)))) -;;; KLUDGE: This function is dangerous, as its overuse could easily -;;; cause stack exhaustion through unbounded recursion. We only use -;;; it in one place; maybe it ought not to be a function at all? +(defvar *invoked-complex-=-other-method* nil) (defun invoke-complex-=-other-method (type1 type2) (let* ((type-class (type-class type1)) (method-fun (type-class-complex-= type-class))) - (if method-fun - (funcall (the function method-fun) type2 type1) + (if (and method-fun (not *invoked-complex-=-other-method*)) + (let ((*invoked-complex-=-other-method* t)) + (funcall (the function method-fun) type2 type1)) (values nil t)))) +;; The following macros expand into either constructor calls, +;; if building the cross-compiler, or forms which reference +;; previously constructed objects, if running the cross-compiler. +#+sb-xc-host +(progn + (defmacro literal-ctype (constructor &optional specifier) + (declare (ignore specifier)) + `(load-time-value ,constructor)) + + (defmacro literal-ctype-vector (var) + `(load-time-value ,var nil))) + +;; Omitting the specifier works only if the unparser method has been +;; defined in time to use it, and you're sure that constructor's result +;; can be unparsed - some unparsers may be confused if called on a +;; non-canonical object, such as an instance of (CONS T T) that is +;; not EQ to the interned instance. +#-sb-xc-host +(progn + (defmacro literal-ctype (constructor &optional (specifier nil specifier-p)) + (if specifier-p (specifier-type specifier) (symbol-value constructor))) + + (defmacro literal-ctype-vector (var) + (symbol-value var))) + ;;;; miscellany ;;; Hash two things (types) down to a target fixnum. In CMU CL this was an EQ @@ -567,8 +589,7 @@ do (setq res (logxor (ash res -1) (type-hash-value type))) finally (return res))) -;;; A few type representations need to be defined slightly earlier than -;;; 'early-type' is compiled, so they're defined here. +;;;; representations of types ;;; The NAMED-TYPE is used to represent *, T and NIL, the standard ;;; special cases, as well as other special cases needed to @@ -584,6 +605,31 @@ (:copier nil)) (name nil :type symbol :read-only t)) +;;; A HAIRY-TYPE represents anything too weird to be described +;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types, +;;; and unreasonably complicated types involving AND. We just remember +;;; the original type spec. +;;; A possible improvement would be for HAIRY-TYPE to have a subtype +;;; named SATISFIES-TYPE for the hairy types which are specifically +;;; of the form (SATISFIES pred) so that we don't have to examine +;;; the sexpr repeatedly to decide whether it takes that form. +;;; And as a further improvement, we might want a table that maps +;;; predicates to their exactly recognized type when possible. +;;; We have such a table in fact - *BACKEND-PREDICATE-TYPES* +;;; as a starting point. But something like PLUSP isn't in there. +;;; On the other hand, either of these points may not be sources of +;;; inefficiency, and the latter if implemented might have undesirable +;;; user-visible ramifications, though it seems unlikely. +(defstruct (hairy-type (:include ctype) + (:constructor %make-hairy-type + (specifier &aux (%bits (pack-ctype-bits hairy)))) + (:constructor !make-interned-hairy-type + (specifier &aux (%bits (pack-interned-ctype-bits 'hairy)))) + (:copier nil)) + ;; the Common Lisp type-specifier of the type we represent. + ;; For other than an unknown type, this must be a (SATISFIES f) expression. + (specifier nil :type t :read-only t)) + ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We ;;; bother with this at this level because MEMBER types are fairly ;;; important and union and intersection are well defined. @@ -671,6 +717,23 @@ (enumerable types)) (:copier nil))) +(defstruct (alien-type-type + (:include ctype (%bits (pack-ctype-bits alien))) + (:constructor %make-alien-type-type (alien-type)) + (:copier nil)) + (alien-type nil :type alien-type :read-only t)) + +(defstruct (negation-type (:include ctype (%bits (pack-ctype-bits negation))) + (:copier nil) + (:constructor make-negation-type (type))) + (type (missing-arg) :type ctype :read-only t)) + +;;; An UNKNOWN-TYPE is a type not known to the type system (not yet +;;; defined). We make this distinction since we don't want to complain +;;; about types that are hairy but defined. +(defstruct (unknown-type (:include hairy-type (%bits (pack-ctype-bits hairy))) + (:copier nil))) + ;;; a list of all the float "formats" (i.e. internal representations; ;;; nothing to do with #'FORMAT), in order of decreasing precision (defglobal *float-formats* @@ -728,34 +791,6 @@ (car-type (missing-arg) :type ctype :read-only t) (cdr-type (missing-arg) :type ctype :read-only t)) -(in-package "SB-ALIEN") -(def!struct (alien-type - (:copier nil) - (:constructor make-alien-type - (&key class bits alignment - &aux (alignment - (or alignment (guess-alignment bits)))))) - (class 'root :type symbol :read-only t) - (bits nil :type (or null unsigned-byte)) - (alignment nil :type (or null unsigned-byte))) -(!set-load-form-method alien-type (:xc :target)) - -(in-package "SB-KERNEL") -(defstruct (alien-type-type - (:include ctype (%bits (pack-ctype-bits alien))) - (:constructor %make-alien-type-type (alien-type)) - (:copier nil)) - (alien-type nil :type alien-type :read-only t)) - -;;; the description of a &KEY argument -(defstruct (key-info #-sb-xc-host (:pure t) - (:copier nil)) - ;; the key (not necessarily a keyword in ANSI Common Lisp) - (name (missing-arg) :type symbol :read-only t) - ;; the type of the argument value - (type (missing-arg) :type ctype :read-only t)) -(declaim (freeze-type key-info)) - ;;; ARGS-TYPE objects are used both to represent VALUES types and ;;; to represent FUNCTION types. (defstruct (args-type (:include ctype) @@ -773,6 +808,22 @@ ;; true if other &KEY arguments are allowed (allowp nil :type boolean :read-only t)) +;;; the description of a &KEY argument +(defstruct (key-info #-sb-xc-host (:pure t) + (:copier nil)) + ;; the key (not necessarily a keyword in ANSI Common Lisp) + (name (missing-arg) :type symbol :read-only t) + ;; the type of the argument value + (type (missing-arg) :type ctype :read-only t)) +(declaim (freeze-type key-info)) + +(defstruct (values-type + (:include args-type (%bits (pack-ctype-bits values))) + (:constructor %make-values-type) + (:copier nil))) + +(declaim (freeze-type values-type)) + ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes (defstruct (fun-type (:include args-type (%bits (pack-ctype-bits function))) (:copier nil) @@ -795,6 +846,38 @@ (:constructor make-fun-designator-type (required optional rest keyp keywords allowp wild-args returns)))) + +;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG +;;; "type specifier", which is only meaningful in function argument +;;; type specifiers used within the compiler. (It represents something +;;; that the compiler knows to be a constant.) +(defstruct (constant-type + (:include ctype (%bits (pack-ctype-bits constant))) + (:copier nil)) + ;; The type which the argument must be a constant instance of for this type + ;; specifier to win. + (type (missing-arg) :type ctype :read-only t)) + + +;;; A SIMD-PACK-TYPE is used to represent a SIMD-PACK type. +#+sb-simd-pack +(defstruct (simd-pack-type + (:include ctype (%bits (pack-ctype-bits simd-pack))) + (:constructor %make-simd-pack-type (element-type)) + (:copier nil)) + (element-type (missing-arg) + :type (cons #||(member #.*simd-pack-element-types*) ||#) + :read-only t)) + +#+sb-simd-pack-256 +(defstruct (simd-pack-256-type + (:include ctype (%bits (pack-ctype-bits simd-pack-256))) + (:constructor %make-simd-pack-256-type (element-type)) + (:copier nil)) + (element-type (missing-arg) + :type (cons #||(member #.*simd-pack-element-types*) ||#) + :read-only t)) + (declaim (ftype (sfunction (ctype ctype) (values t t)) csubtypep)) ;;; Look for nice relationships for types that have nice relationships ;;; only when one is a hierarchical subtype of the other. @@ -817,18 +900,6 @@ ((csubtypep type2 type1) type1) (t nil))) -;; KLUDGE: putting this here satisfies CMUCL for an inexplicable reason. -;; It should suffice to put it anywhere before %MAKE-CHARACTER-SET-TYPE -;; is actually called. -;; -;; all character-set types are enumerable, but it's not possible -;; for one to be TYPE= to a MEMBER type because (MEMBER #\x) -;; is not internally represented as a MEMBER type. -;; So in case it wasn't clear already ENUMERABLE-P does not mean -;; "possibly a MEMBER type in the Lisp-theoretic sense", -;; but means "could be implemented in SBCL as a MEMBER type". -(define-type-class character-set :enumerable nil - :might-contain-other-types nil) (!defun-from-collected-cold-init-forms !type-class-cold-init) ;;; CAUTION: unhygienic macro specifically designed to expand into body code @@ -901,7 +972,7 @@ (values nil nil)))) ; can't decide (test-character-type (type) (when (characterp ,thing) - (let ((code (sb-xc:char-code ,thing))) + (let ((code (char-code ,thing))) (dolist (pair (character-set-type-pairs type) nil) (destructuring-bind (low . high) pair (when (<= low code high) @@ -909,7 +980,7 @@ ;; It should always work to dispatch by class-id, but ALIEN-TYPE-TYPE ;; is a problem in the cross-compiler due to not having a type-class-id ;; when 'src/code/cross-type' is compiled. I briefly tried moving - ;; it later, but then class-init failed to compile. + ;; it later, but then type-init failed to compile. #+sb-xc-host (etypecase type ,@clauses) #-sb-xc-host diff -Nru sbcl-2.1.1/src/code/type-init.lisp sbcl-2.1.11/src/code/type-init.lisp --- sbcl-2.1.1/src/code/type-init.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/type-init.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -1,10 +1,10 @@ ;;;; When this file's top level forms are run, it precomputes the ;;;; translations for commonly used type specifiers. This stuff is ;;;; split off from the other type stuff to get around problems with -;;;; everything needing to be loaded before everything else. This -;;;; stuff is also somewhat implementation-dependent in that -;;;; implementations may want to precompute other types which are -;;;; important to them. +;;;; everything needing to be loaded before everything else. This file +;;;; is the first to exercise the type machinery. This stuff is also +;;;; somewhat implementation-dependent in that implementations may +;;;; want to precompute other types which are important to them. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -17,11 +17,36 @@ (in-package "SB-KERNEL") +;;; built-in classes +(/show0 "beginning type-init.lisp") +#+sb-xc-host +(dolist (x *builtin-classoids*) + (destructuring-bind (name &key (translation nil trans-p) &allow-other-keys) + x + (/show "doing class with" name) + (when trans-p + (let ((classoid (classoid-cell-classoid (find-classoid-cell name :create t))) + (type (specifier-type translation))) + (when (typep (built-in-classoid-translation classoid) 'ctype) + (aver (eq (built-in-classoid-translation classoid) type))) + (setf (built-in-classoid-translation classoid) type) + (setf (info :type :builtin name) type))))) + +;;; the Common Lisp defined type spec symbols +(defconstant-eqx +!standard-type-names+ + '(array atom bignum bit bit-vector character compiled-function + complex cons double-float extended-char fixnum float function + hash-table integer keyword list long-float nil null number package + pathname random-state ratio rational real readtable sequence + short-float simple-array simple-bit-vector simple-string simple-vector + single-float standard-char stream string base-char symbol t vector) + #'equal) + ;;; built-in symbol type specifiers ;;; Predefined types that are of kind :INSTANCE can't have their ;;; :BUILTIN property set, so we cull them out. This used to operate -;;; on all *!STANDARD-TYPE-NAMES* because !PRECOMPUTE-TYPES was ok to +;;; on all +!STANDARD-TYPE-NAMES+ because !PRECOMPUTE-TYPES was ok to ;;; call on unknown types. This relied upon the knowledge that ;;; VALUES-SPECIFIER-TYPE avoided signaling a PARSE-UNKNOWN-TYPE ;;; condition while in cold-init. This is terrible! It means that @@ -38,7 +63,7 @@ (remove-if (lambda (x) (memq x '(compiled-function hash-table package pathname random-state readtable))) - *!standard-type-names*)) + +!standard-type-names+)) #+sb-xc-host (setf *type-system-initialized* t) diff -Nru sbcl-2.1.1/src/code/type.lisp sbcl-2.1.11/src/code/type.lisp --- sbcl-2.1.1/src/code/type.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/code/type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,5572 @@ +;;;; This file contains the definition of non-CLASS types (e.g. +;;;; subtypes of interesting BUILT-IN-CLASSes) and the interfaces to +;;;; the type system. Common Lisp type specifiers are parsed into a +;;;; somewhat canonical internal type representation that supports +;;;; type union, intersection, etc. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-KERNEL") + +(!begin-collecting-cold-init-forms) + +;;; ### Remaining incorrectnesses: +;;; +;;; There are all sorts of nasty problems with open bounds on FLOAT +;;; types (and probably FLOAT types in general.) + +;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that +;;; compiler warnings can be emitted as appropriate. +(define-condition parse-unknown-type (condition) + ((specifier :reader parse-unknown-type-specifier :initarg :specifier)) + (:default-initargs + :specifier (missing-arg))) + +;;; This condition is signalled whenever we encounter a type (DEFTYPE, +;;; structure, condition, class) that has been marked as deprecated. +(define-condition parse-deprecated-type (condition) + ((specifier :reader parse-deprecated-type-specifier :initarg :specifier)) + (:default-initargs + :specifier (missing-arg))) + +;;; For-effect-only variant of CHECK-DEPRECATED-THING for +;;; type-specifiers that descends into compound type-specifiers. +(defun sb-impl::%check-deprecated-type (type-specifier) + (let ((seen '())) + ;; KLUDGE: we have to use SPECIFIER-TYPE to sanely traverse + ;; TYPE-SPECIFIER and detect references to deprecated types. But + ;; then we may have to drop its cache to get the + ;; PARSE-DEPRECATED-TYPE condition when TYPE-SPECIFIER is parsed + ;; again later. + ;; + ;; Proper fix would be a + ;; + ;; walk-type function type-specifier + ;; + ;; mechanism that could drive VALUES-SPECIFIER-TYPE but also + ;; things like this function. + (block nil + (handler-bind + ((parse-deprecated-type + (lambda (condition) + (let ((type-specifier (parse-deprecated-type-specifier condition))) + (aver (symbolp type-specifier)) + (unless (memq type-specifier seen) + (push type-specifier seen) + (check-deprecated-thing 'type type-specifier))))) + ((or error parse-unknown-type) + (lambda (condition) + (declare (ignore condition)) + (return)))) + (specifier-type type-specifier))))) + +(defun check-slot-type-specifier (specifier slot-name context) + ;; This signals an error for malformed type specifiers and + ;; deprecation warnings for deprecated types but does nothing for + ;; unknown types. + (with-current-source-form (specifier) + (handler-case + (and (specifier-type specifier) + (sb-impl::%check-deprecated-type specifier)) + (parse-unknown-type (c) + (when (typep specifier '(cons (eql quote))) + (signal c))) + (error (condition) + (destructuring-bind (operator . class-name) context + (sb-c:compiler-warn "Invalid :TYPE for slot ~S in ~S ~S: ~A." + slot-name operator class-name condition)))))) + +(defun maybe-reparse-specifier (type) + (when (unknown-type-p type) + (let* ((spec (unknown-type-specifier type)) + (name (if (consp spec) + (car spec) + spec))) + (when (info :type :kind name) + (let ((new-type (specifier-type spec))) + (unless (unknown-type-p new-type) + new-type)))))) + +;;; Evil macro. +(defmacro maybe-reparse-specifier! (type) + (aver (symbolp type)) + (with-unique-names (new-type) + `(let ((,new-type (maybe-reparse-specifier ,type))) + (when ,new-type + (setf ,type ,new-type) + t)))) + +;;; These functions are used as method for types which need a complex +;;; subtypep method to handle some superclasses, but cover a subtree +;;; of the type graph (i.e. there is no simple way for any other type +;;; class to be a subtype.) There are always still complex ways, +;;; namely UNION and MEMBER types, so we must give TYPE1's method a +;;; chance to run, instead of immediately returning NIL, T. +(defun delegate-complex-subtypep-arg2 (type1 type2) + (let ((subtypep-arg1 + (type-class-complex-subtypep-arg1 (type-class type1)))) + (if subtypep-arg1 + (funcall subtypep-arg1 type1 type2) + (values nil t)))) +(defun delegate-complex-intersection2 (type1 type2) + (let ((method (type-class-complex-intersection2 (type-class type1)))) + (if (and method (not (eq method #'delegate-complex-intersection2))) + (funcall method type2 type1) + (hierarchical-intersection2 type1 type2)))) + +(defun map-type (function ctype) + (declare (type (or ctype null) ctype) + (dynamic-extent function)) + (named-let %map ((type ctype)) + (funcall function type) + (typecase type + (compound-type + (mapc #'%map (compound-type-types type))) + (negation-type (%map (negation-type-type type))) + (cons-type + (%map (cons-type-car-type type)) + (%map (cons-type-cdr-type type))) + (array-type + (%map (array-type-element-type type))) + (args-type + (mapc #'%map (args-type-required type)) + (mapc #'%map (args-type-optional type)) + (when (args-type-rest type) + (%map (args-type-rest type))) + (mapc (lambda (x) (%map (key-info-type x))) + (args-type-keywords type)) + (when (fun-type-p type) + (%map (fun-type-returns type)))))) + nil) + +(defun contains-unknown-type-p (ctype) + (map-type (lambda (type) + (when (unknown-type-p type) + (return-from contains-unknown-type-p t))) + ctype)) + +(defun contains-hairy-type-p (ctype) + (map-type (lambda (type) + (when (hairy-type-p type) + (return-from contains-hairy-type-p t))) + ctype)) + +(defun replace-hairy-type (type) + (if (contains-hairy-type-p type) + (typecase type + (hairy-type *universal-type*) + (intersection-type (%type-intersection + (mapcar #'replace-hairy-type (intersection-type-types type)))) + (union-type (%type-union + (mapcar #'replace-hairy-type (union-type-types type)))) + (negation-type + (let ((new (replace-hairy-type (negation-type-type type)))) + (if (eq new *universal-type*) + new + (type-negation new)))) + (t + *universal-type*)) + type)) + +;; Similar to (NOT CONTAINS-UNKNOWN-TYPE-P), but report that (SATISFIES F) +;; is not a testable type unless F is currently bound. +(defun testable-type-p (ctype) + (map-type + (lambda (ctype) + (typecase ctype + (unknown-type + (return-from testable-type-p nil)) ; must precede HAIRY because an unknown is HAIRY + (hairy-type + (let ((spec (hairy-type-specifier ctype))) + ;; Anything other than (SATISFIES ...) is testable + ;; because there's no reason to suppose that it isn't. + (unless (or (neq (car spec) 'satisfies) (fboundp (cadr spec))) + (return-from testable-type-p nil)))))) + ctype) + t) + +;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 +;;; method. INFO is a list of conses +;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). +(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) + ;; If TYPE2 might be concealing something related to our class + ;; hierarchy + (cond ((type-might-contain-other-types-p type2) + ;; too confusing, gotta punt + (values nil nil)) + ((fun-designator-type-p type1) + (values nil t)) + (t + ;; ordinary case expected by old CMU CL code, where the taxonomy + ;; of TYPE2's representation accurately reflects the taxonomy of + ;; the underlying set + (values + ;; FIXME: This old CMU CL code probably deserves a comment + ;; explaining to us mere mortals how it works... + (and (sb-xc:typep type2 'classoid) + (dolist (x info nil) + (let ((guard (cdr x))) + (when (or (not guard) + (csubtypep type1 (if (%instancep guard) + guard + (setf (cdr x) + (specifier-type guard))))) + (return + (or (eq type2 (car x)) + (let ((inherits (wrapper-inherits + (classoid-wrapper (car x))))) + (dotimes (i (length inherits) nil) + (when (eq type2 (wrapper-classoid (svref inherits i))) + (return t)))))))))) + t)))) + +;;; This function takes a list of specs, each of the form +;;; (SUPERCLASS-NAME &OPTIONAL GUARD). +;;; Consider one spec (with no guard): any instance of the named +;;; TYPE-CLASS is also a subtype of the named superclass and of any of +;;; its superclasses. If there are multiple specs, then some will have +;;; guards. We choose the first spec whose guard is a supertype of +;;; TYPE1 and use its superclass. In effect, a sequence of guards +;;; G0, G1, G2 +;;; is actually +;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))). +;;; +;;; WHEN controls when the forms are executed. +(defmacro !define-superclasses (type-class-name specs progn-oid) + (let ((defun-name (symbolicate type-class-name "-COMPLEX-SUBTYPEP-ARG1"))) + `(progn + (defun ,defun-name (type1 type2) + (has-superclasses-complex-subtypep-arg1 + type1 type2 + (load-time-value + (list ,@(mapcar (lambda (spec) + (destructuring-bind (super &optional guard) spec + `(cons (find-classoid ',super) ',guard))) + specs)) #-sb-xc-host t))) + (,progn-oid + (let ((type-class (type-class-or-lose ',type-class-name))) + (setf (type-class-complex-subtypep-arg1 type-class) #',defun-name) + (setf (type-class-complex-subtypep-arg2 type-class) + #'delegate-complex-subtypep-arg2) + (setf (type-class-complex-intersection2 type-class) + #'delegate-complex-intersection2)))))) + +;;;; FUNCTION and VALUES types +;;;; +;;;; Pretty much all of the general type operations are illegal on +;;;; VALUES types, since we can't discriminate using them, do +;;;; SUBTYPEP, etc. FUNCTION types are acceptable to the normal type +;;;; operations, but are generally considered to be equivalent to +;;;; FUNCTION. These really aren't true types in any type theoretic +;;;; sense, but we still parse them into CTYPE structures for two +;;;; reasons: + +;;;; -- Parsing and unparsing work the same way, and indeed we can't +;;;; tell whether a type is a function or values type without +;;;; parsing it. +;;;; -- Many of the places that can be annotated with real types can +;;;; also be annotated with function or values types. + +(define-type-class values :enumerable nil :might-contain-other-types nil) + +(defun-cached (make-values-type-cached + :hash-bits 8 + :hash-function + (lambda (req opt rest allowp) + (logxor (type-list-cache-hash req) + (type-list-cache-hash opt) + (if rest + (type-hash-value rest) + 42) + ;; Results (logand #xFF (sxhash t/nil)) + ;; hardcoded to avoid relying on the xc host. + ;; [but (logand (sxhash nil) #xff) => 2 + ;; for me, so the code and comment disagree, + ;; but not in a way that matters.] + (if allowp + 194 + 11)))) + ((required equal-but-no-car-recursion) + (optional equal-but-no-car-recursion) + (rest eq) + (allowp eq)) + (%make-values-type :required required + :optional optional + :rest rest + :allowp allowp)) + +(defun make-values-type (&key required optional rest allowp) + (multiple-value-bind (required optional rest) + (canonicalize-args-type-args required optional rest) + (cond ((and (null required) + (null optional) + (eq rest *universal-type*)) + *wild-type*) + ((memq *empty-type* required) + *empty-type*) + (t (make-values-type-cached required optional + rest allowp))))) + +(define-type-method (values :simple-subtypep :complex-subtypep-arg1) + (type1 type2) + (declare (ignore type2)) + ;; FIXME: should be TYPE-ERROR, here and in next method + (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1))) + +(define-type-method (values :complex-subtypep-arg2) + (type1 type2) + (declare (ignore type1)) + (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2))) + +(define-type-method (values :negate) (type) + (error "NOT VALUES too confusing on ~S" (type-specifier type))) + +(define-type-method (values :unparse) (type) + (cons 'values + (let ((unparsed (unparse-args-types type))) + (if (or (values-type-optional type) + (values-type-rest type) + (values-type-allowp type)) + unparsed + (nconc unparsed '(&optional)))))) + +;;; Return true if LIST1 and LIST2 have the same elements in the same +;;; positions according to TYPE=. We return NIL, NIL if there is an +;;; uncertain comparison. +(defun type=-list (list1 list2) + (declare (list list1 list2)) + (do ((types1 list1 (cdr types1)) + (types2 list2 (cdr types2))) + ((or (null types1) (null types2)) + (if (or types1 types2) + (values nil t) + (values t t))) + (multiple-value-bind (val win) + (type= (first types1) (first types2)) + (unless win + (return (values nil nil))) + (unless val + (return (values nil t)))))) + +(define-type-method (values :simple-=) (type1 type2) + (type=-args type1 type2)) + +;;; a flag that we can bind to cause complex function types to be +;;; unparsed as FUNCTION. This is useful when we want a type that we +;;; can pass to TYPEP. +(defvar *unparse-fun-type-simplify* nil) + +(define-type-class function :enumerable nil :might-contain-other-types nil) + +(define-type-method (function :negate) (type) (make-negation-type type)) + +(define-type-method (function :unparse) (type) + (let ((name (if (fun-designator-type-p type) + 'function-designator + 'function))) + (cond (*unparse-fun-type-simplify* + name) + (t + (list name + (if (fun-type-wild-args type) + '* + (unparse-args-types type)) + (type-specifier + (fun-type-returns type))))))) + +;;; The meaning of this is a little confused. On the one hand, all +;;; function objects are represented the same way regardless of the +;;; arglists and return values, and apps don't get to ask things like +;;; (TYPEP #'FOO (FUNCTION (FIXNUM) *)) in any meaningful way. On the +;;; other hand, Python wants to reason about function types. So... +(define-type-method (function :simple-subtypep) (type1 type2) + (cond ((and (fun-designator-type-p type1) + (not (fun-designator-type-p type2))) + (values nil t)) + ((type= type1 type2) + ;; Since the following doesn't handle &rest or &key at least + ;; pick out equal types. + (values t t)) + (t + (flet ((fun-type-simple-p (type) + (not (or (fun-type-rest type) + (fun-type-keyp type)))) + (every-csubtypep (types1 types2) + (loop + for a1 in types1 + for a2 in types2 + do (multiple-value-bind (res sure-p) + (csubtypep a1 a2) + (unless res (return (values res sure-p)))) + finally (return (values t t))))) + (and/type (values-subtypep (fun-type-returns type1) + (fun-type-returns type2)) + (cond ((fun-type-wild-args type2) (values t t)) + ((fun-type-wild-args type1) + (cond ((fun-type-keyp type2) (values nil nil)) + ((not (fun-type-rest type2)) (values nil t)) + ((not (null (fun-type-required type2))) + (values nil t)) + (t (and/type (type= *universal-type* + (fun-type-rest type2)) + (every/type #'type= + *universal-type* + (fun-type-optional + type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (fun-type-nargs type1) + (multiple-value-bind (min2 max2) (fun-type-nargs type2) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (and/type (every-csubtypep + (fun-type-required type1) + (fun-type-required type2)) + (every-csubtypep + (fun-type-optional type1) + (fun-type-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (fun-type-required type1) + (fun-type-optional type1)) + (concatenate 'list + (fun-type-required type2) + (fun-type-optional type2)))))))))))))) + +(!define-superclasses function ((function)) !cold-init-forms) + +;;; The union or intersection of two FUNCTION types is FUNCTION. +(define-type-method (function :simple-union2) (type1 type2) + (if (or (fun-designator-type-p type1) + (fun-designator-type-p type2)) + (specifier-type 'function-designator) + (specifier-type 'function))) + +(define-type-method (function :simple-intersection2) (type1 type2) + (let ((ftype (specifier-type 'function))) + (cond ((eq type1 ftype) type2) + ((eq type2 ftype) type1) + (t (let ((rtype (values-type-intersection (fun-type-returns type1) + (fun-type-returns type2))) + (designator + (and (fun-designator-type-p type1) + (fun-designator-type-p type2)))) + (flet ((change-returns (ftype rtype) + (declare (type fun-type ftype) (type ctype rtype)) + (make-fun-type :required (fun-type-required ftype) + :optional (fun-type-optional ftype) + :keyp (fun-type-keyp ftype) + :keywords (fun-type-keywords ftype) + :allowp (fun-type-allowp ftype) + :returns rtype + :designator designator))) + (cond + ((fun-type-wild-args type1) + (if (fun-type-wild-args type2) + (make-fun-type :wild-args t + :returns rtype + :designator designator) + (change-returns type2 rtype))) + ((fun-type-wild-args type2) + (change-returns type1 rtype)) + (t (multiple-value-bind (req opt rest) + (args-type-op type1 type2 #'type-intersection #'max) + (make-fun-type :required req + :optional opt + :rest rest + ;; FIXME: :keys + :allowp (and (fun-type-allowp type1) + (fun-type-allowp type2)) + :returns rtype + :designator designator)))))))))) + +;;; The union or intersection of a subclass of FUNCTION with a +;;; FUNCTION type is somewhat complicated. +(define-type-method (function :complex-intersection2) (type1 type2) + (cond + ((and (fun-designator-type-p type2) + (or (csubtypep type1 (specifier-type 'symbol)) + (csubtypep type1 (specifier-type 'function)))) + type1) + ((type= type1 (specifier-type 'function)) type2) + ((csubtypep type1 (specifier-type 'function)) nil) + (t :call-other-method))) +(define-type-method (function :complex-union2) (type1 type2) + (declare (ignore type2)) + ;; TYPE2 is a FUNCTION type. If TYPE1 is a classoid type naming + ;; FUNCTION, then it is the union of the two; otherwise, there is no + ;; special union. + (cond + ((type= type1 (specifier-type 'function)) type1) + (t nil))) + +(define-type-method (function :simple-=) (type1 type2) + (if (or (and (fun-designator-type-p type1) + (not (fun-designator-type-p type2))) + (and (not (fun-designator-type-p type1)) + (fun-designator-type-p type2))) + (values nil t) + (macrolet ((compare (comparator field) + (let ((reader (symbolicate '#:fun-type- field))) + `(,comparator (,reader type1) (,reader type2))))) + (and/type (compare type= returns) + (cond ((neq (fun-type-wild-args type1) (fun-type-wild-args type2)) + (values nil t)) + ((eq (fun-type-wild-args type1) t) + (values t t)) + (t (type=-args type1 type2))))))) + +#+sb-xc-host +(defvar *interned-fun-types* + (flet ((fun-type (n) + (!make-interned-fun-type (pack-interned-ctype-bits 'function) + (make-list n :initial-element *universal-type*) + nil nil nil nil nil nil *wild-type*))) + (vector (fun-type 0) (fun-type 1) (fun-type 2) (fun-type 3)))) + +(defun make-fun-type (&key required optional rest + keyp keywords allowp + wild-args returns + designator) + (let ((rest (if (eq rest *empty-type*) nil rest)) + (n (length required))) + (cond (designator + (make-fun-designator-type required optional rest keyp keywords + allowp wild-args returns)) + ((and + (<= n 3) + (not optional) (not rest) (not keyp) + (not keywords) (not allowp) (not wild-args) + (eq returns *wild-type*) + (not (find *universal-type* required :test #'neq))) + (svref (literal-ctype-vector *interned-fun-types*) n)) + (t + (%make-fun-type required optional rest keyp keywords + allowp wild-args returns))))) + +;; This seems to be used only by cltl2, and within 'cross-type', +;; where it is never used, which makes sense, since pretty much we +;; never want this object, but instead the classoid FUNCTION +;; if we know nothing about a function's signature. +;; Maybe this should not exist unless cltl2 is loaded??? +(define-load-time-global *universal-fun-type* + (make-fun-type :wild-args t :returns *wild-type*)) + +(define-type-class constant :inherits values) + +(define-type-method (constant :negate) (type) + (error "NOT CONSTANT too confusing on ~S" (type-specifier type))) + +(define-type-method (constant :unparse) (type) + `(constant-arg ,(type-specifier (constant-type-type type)))) + +(define-type-method (constant :simple-=) (type1 type2) + (type= (constant-type-type type1) (constant-type-type type2))) + +(def-type-translator constant-arg ((:context context) type) + (make-constant-type :type (single-value-specifier-type type context))) + +(defun canonicalize-args-type-args (required optional rest &optional keyp) + (when (eq rest *empty-type*) + ;; or vice-versa? + (setq rest nil)) + (loop with last-not-rest = nil + for i from 0 + for opt in optional + do (cond ((eq opt *empty-type*) + (return (values required (subseq optional 0 i) rest))) + ((and (not keyp) (neq opt rest)) + (setq last-not-rest i))) + finally (return (values required + (cond (keyp + optional) + (last-not-rest + (subseq optional 0 (1+ last-not-rest)))) + rest)))) + +;;; CONTEXT is the cookie passed down from the outermost surrounding call +;;; of BASIC-PARSE-TYPE. INNER-CONTEXT-KIND is an indicator of whether +;;; we are currently parsing a FUNCTION or a VALUES compound type specifier. +;;; If the entire LAMBDA-LISTY-THING is *, we do not call this function at all. +;;; If an element of it is *, that constitutes an error, as is clear +;;; for VALUES: "The symbol * may not be among the value-types." +;;; http://www.lispworks.com/documentation/HyperSpec/Body/t_values.htm +;;; and the FUNCTION compound type, for which the grammar is: +;;; function [arg-typespec [value-typespec]] +;;; arg-typespec::= (typespec* [&optional typespec*] [&rest typespec];[&key (keyword typespec)*]) +;;; typespec --- a type specifier. +;;; where the glossary says: "type specifier: n. an expression that denotes a type." +;;; which of course * does not denote, and is made all the more clear by the fact +;;; that the AND, OR, and NOT combinators explicitly preclude * as an element. +(defun parse-args-types (context lambda-listy-thing inner-context-kind) + (multiple-value-bind (llks required optional rest keys) + (parse-lambda-list + lambda-listy-thing + :context inner-context-kind + :accept (ecase inner-context-kind + (:values-type (lambda-list-keyword-mask '(&optional &rest))) + (:function-type (lambda-list-keyword-mask + '(&optional &rest &key &allow-other-keys)))) + :silent t) + (labels ((parse-list (list) (mapcar #'parse-one list)) + (parse-one (x) + (specifier-type x context + (case inner-context-kind + (:function-type 'function) + (t 'values))))) + (let ((required (parse-list required)) + (optional (parse-list optional)) + (rest (when rest (parse-one (car rest)))) + (keywords + (collect ((key-info)) + (dolist (key keys) + (unless (proper-list-of-length-p key 2) + (error "Keyword type description is not a two-list: ~S." key)) + (let ((kwd (first key))) + (when (find kwd (key-info) :key #'key-info-name) + (error (sb-format:tokens + "~@") + kwd lambda-listy-thing)) + (key-info + (make-key-info + ;; MAKE-KEY-INFO will complain if KWD is not a symbol. + ;; That's good enough - we don't need an extra check here. + :name kwd + :type (single-value-specifier-type (second key) context))))) + (key-info)))) + (multiple-value-bind (required optional rest) + (canonicalize-args-type-args required optional rest + (ll-kwds-keyp llks)) + (values llks required optional rest keywords)))))) + +;;; Return the lambda-list-like type specification corresponding +;;; to an ARGS-TYPE. +(declaim (ftype (function (args-type) list) unparse-args-types)) +(defun unparse-args-types (type) + (collect ((result)) + + (dolist (arg (args-type-required type)) + (result (type-specifier arg))) + + (when (args-type-optional type) + (result '&optional) + (dolist (arg (args-type-optional type)) + (result (type-specifier arg)))) + + (when (args-type-rest type) + (result '&rest) + (result (type-specifier (args-type-rest type)))) + + (when (args-type-keyp type) + (result '&key) + (dolist (key (args-type-keywords type)) + (result (list (key-info-name key) + (type-specifier (key-info-type key)))))) + + (when (args-type-allowp type) + (result '&allow-other-keys)) + + (result))) + +(defun translate-fun-type (context args result + &key designator) + (let ((result (coerce-to-values (basic-parse-typespec result context)))) + (cond ((neq args '*) + (multiple-value-bind (llks required optional rest keywords) + (parse-args-types context args :function-type) + (if (and (null required) + (null optional) + (eq rest *universal-type*) + (not (ll-kwds-keyp llks))) + (if (eq result *wild-type*) + (specifier-type 'function) + (make-fun-type :wild-args t :returns result + :designator designator)) + (make-fun-type :required required + :optional optional + :rest rest + :keyp (ll-kwds-keyp llks) + :keywords keywords + :allowp (ll-kwds-allowp llks) + :returns result + :designator designator)))) + ((eq result *wild-type*) + (if designator + ;; Do not put 'FUNCTION-DESIGNATOR here! + ;; (Since this is the parser for FUNCTION-DESIGNATOR) + (specifier-type '(or function symbol)) + (specifier-type 'function))) + (t + (make-fun-type :wild-args t :returns result + :designator designator))))) + +(def-type-translator function ((:context context) + &optional (args '*) (result '*)) + (translate-fun-type context args result)) + +(def-type-translator function-designator ((:context context) + &optional (args '*) (result '*)) + (translate-fun-type context args result :designator t)) + +(def-type-translator values :list ((:context context) &rest values) + (multiple-value-bind (llks required optional rest) + (parse-args-types context values :values-type) + (if (plusp llks) + (make-values-type :required required :optional optional :rest rest) + (make-short-values-type required)))) + +;;;; VALUES types interfaces +;;;; +;;;; We provide a few special operations that can be meaningfully used +;;;; on VALUES types (as well as on any other type). + +;;; Return the minimum number of values possibly matching VALUES type +;;; TYPE. +(defun values-type-min-value-count (type) + (etypecase type + (named-type + (ecase (named-type-name type) + ((t *) 0) + ((nil) 0))) + (values-type + (length (values-type-required type))))) + +;;; Return the maximum number of values possibly matching VALUES type +;;; TYPE. +(defun values-type-max-value-count (type) + (etypecase type + (named-type + (ecase (named-type-name type) + ((t *) call-arguments-limit) + ((nil) 0))) + (values-type + (if (values-type-rest type) + call-arguments-limit + (+ (length (values-type-optional type)) + (length (values-type-required type))))))) + +(defun values-type-may-be-single-value-p (type) + (<= (values-type-min-value-count type) + 1 + (values-type-max-value-count type))) + +;;; VALUES type with a single value. +(defun type-single-value-p (type) + (and (values-type-p type) + (not (values-type-rest type)) + (null (values-type-optional type)) + (singleton-p (values-type-required type)))) + +;;; Return the type of the first value indicated by TYPE. This is used +;;; by people who don't want to have to deal with VALUES types. +(defun single-value-type (type) + (declare (type ctype type)) + (cond ((eq type *wild-type*) + *universal-type*) + ((eq type *empty-type*) + *empty-type*) + ((not (values-type-p type)) + type) + ((car (args-type-required type))) + (t (type-union (specifier-type 'null) + (or (car (args-type-optional type)) + (args-type-rest type) + (specifier-type 'null)))))) + +;;; Return the minimum number of arguments that a function can be +;;; called with, and the maximum number or NIL. If not a function +;;; type, return NIL, NIL. +(defun fun-type-nargs (type) + (declare (type ctype type)) + (if (and (fun-type-p type) (not (fun-type-wild-args type))) + (let ((fixed (length (args-type-required type)))) + (if (or (args-type-rest type) + (args-type-keyp type) + (args-type-allowp type)) + (values fixed nil) + (values fixed (+ fixed (length (args-type-optional type)))))) + (values nil nil))) + +;;; Determine whether TYPE corresponds to a definite number of values. +;;; The first value is a list of the types for each value, and the +;;; second value is the number of values. If the number of values is +;;; not fixed, then return NIL and :UNKNOWN. +(defun values-types (type) + (declare (type ctype type)) + (cond ((or (eq type *wild-type*) (eq type *empty-type*)) + (values nil :unknown)) + ((or (args-type-optional type) + (args-type-rest type)) + (values nil :unknown)) + (t + (let ((req (args-type-required type))) + (values req (length req)))))) + +;;; Return two values: +;;; 1. A list of all the positional (fixed and optional) types. +;;; 2. The &REST type (if any). If no &REST, then the DEFAULT-TYPE. +(defun values-type-types (type &optional (default-type *empty-type*)) + (declare (type ctype type)) + (if (eq type *wild-type*) + (values nil *universal-type*) + (values (append (args-type-required type) + (args-type-optional type)) + (or (args-type-rest type) + default-type)))) + +;;; types of values in (the (values o_1 ... o_n)) +(defun values-type-out (type count) + (declare (type ctype type) (type unsigned-byte count)) + (if (eq type *wild-type*) + (make-list count :initial-element *universal-type*) + (collect ((res)) + (flet ((process-types (types) + (loop for type in types + while (plusp count) + do (decf count) + do (res type)))) + (process-types (values-type-required type)) + (process-types (values-type-optional type)) + (let ((rest (values-type-rest type))) + (when rest + (loop repeat count + do (res rest))))) + (res)))) + +;;; types of variable in (m-v-bind (v_1 ... v_n) (the ... +(defun values-type-in (type count) + (declare (type ctype type) (type unsigned-byte count)) + (if (eq type *wild-type*) + (make-list count :initial-element *universal-type*) + (collect ((res)) + (let ((null-type (specifier-type 'null))) + (loop for type in (values-type-required type) + while (plusp count) + do (decf count) + do (res type)) + (loop for type in (values-type-optional type) + while (plusp count) + do (decf count) + do (res (type-union type null-type))) + (when (plusp count) + (loop with rest = (acond ((values-type-rest type) + (type-union it null-type)) + (t null-type)) + repeat count + do (res rest)))) + (res)))) + +;;; Return a list of OPERATION applied to the types in TYPES1 and +;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter +;;; than TYPES2. The second value is T if OPERATION always returned a +;;; true second value. +(defun fixed-values-op (types1 types2 rest2 operation) + (declare (list types1 types2) (type ctype rest2) (type function operation)) + (let ((exact t)) + (values (mapcar (lambda (t1 t2) + (multiple-value-bind (res win) + (funcall operation t1 t2) + (unless win + (setq exact nil)) + res)) + types1 + (append types2 + (make-list (- (length types1) (length types2)) + :initial-element rest2))) + exact))) + +;;; If TYPE isn't a values type, then make it into one. +(defun-cached (%coerce-to-values :hash-bits 8 :hash-function #'type-hash-value) + ((type eq)) + (cond ((multiple-value-bind (res sure) + (csubtypep (specifier-type 'null) type) + (and (not res) sure)) + ;; FIXME: What should we do with (NOT SURE)? + (make-values-type :required (list type) :rest *universal-type*)) + (t + (make-values-type :optional (list type) :rest *universal-type*)))) + +(defun coerce-to-values (type) + (declare (type ctype type)) + (cond ((or (eq type *universal-type*) + (eq type *wild-type*)) + *wild-type*) + ((values-type-p type) + type) + (t (%coerce-to-values type)))) + +;;; Return type, corresponding to ANSI short form of VALUES type +;;; specifier. +(defun make-short-values-type (types) + (declare (list types)) + (let ((last-required (position-if + (lambda (type) + (not/type (csubtypep (specifier-type 'null) type))) + types + :from-end t))) + (if last-required + (make-values-type :required (subseq types 0 (1+ last-required)) + :optional (subseq types (1+ last-required)) + :rest *universal-type*) + (make-values-type :optional types :rest *universal-type*)))) + +(defun make-single-value-type (type) + (make-values-type :required (list type))) + +;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any +;;; type, including VALUES types. With VALUES types such as: +;;; (VALUES a0 a1) +;;; (VALUES b0 b1) +;;; we compute the more useful result +;;; (VALUES ( a0 b0) ( a1 b1)) +;;; rather than the precise result +;;; ( (values a0 a1) (values b0 b1)) +;;; This has the virtue of always keeping the VALUES type specifier +;;; outermost, and retains all of the information that is really +;;; useful for static type analysis. We want to know what is always +;;; true of each value independently. It is worthless to know that if +;;; the first value is B0 then the second will be B1. +;;; +;;; If the VALUES count signatures differ, then we produce a result with +;;; the required VALUE count chosen by NREQ when applied to the number +;;; of required values in TYPE1 and TYPE2. Any &KEY values become +;;; &REST T (anyone who uses keyword values deserves to lose.) +;;; +;;; The second value is true if the result is definitely empty or if +;;; OPERATION returned true as its second value each time we called +;;; it. Since we approximate the intersection of VALUES types, the +;;; second value being true doesn't mean the result is exact. +(defun args-type-op (type1 type2 operation nreq) + (declare (type ctype type1 type2) + (type function operation nreq)) + (when (eq type1 type2) + (values type1 t)) + (multiple-value-bind (types1 rest1) + (values-type-types type1) + (multiple-value-bind (types2 rest2) + (values-type-types type2) + (multiple-value-bind (rest rest-exact) + (funcall operation rest1 rest2) + (multiple-value-bind (res res-exact) + (if (< (length types1) (length types2)) + (fixed-values-op types2 types1 rest1 operation) + (fixed-values-op types1 types2 rest2 operation)) + (let* ((req (funcall nreq + (length (args-type-required type1)) + (length (args-type-required type2)))) + (required (subseq res 0 req)) + (opt (subseq res req))) + (values required opt rest + (and rest-exact res-exact)))))))) + +(defun values-type-op (type1 type2 operation nreq) + (multiple-value-bind (required optional rest exactp) + (args-type-op type1 type2 operation nreq) + (values (make-values-type :required required + :optional optional + :rest rest) + exactp))) + +(defun compare-key-args (type1 type2) + (let ((keys1 (args-type-keywords type1)) + (keys2 (args-type-keywords type2))) + (and (= (length keys1) (length keys2)) + (eq (args-type-allowp type1) + (args-type-allowp type2)) + (loop for key1 in keys1 + for match = (find (key-info-name key1) + keys2 :key #'key-info-name) + always (and match + (type= (key-info-type key1) + (key-info-type match))))))) + +(defun type=-args (type1 type2) + (macrolet ((compare (comparator field) + (let ((reader (symbolicate '#:args-type- field))) + `(,comparator (,reader type1) (,reader type2))))) + (and/type + (cond ((null (args-type-rest type1)) + (values (null (args-type-rest type2)) t)) + ((null (args-type-rest type2)) + (values nil t)) + (t + (compare type= rest))) + (and/type (and/type (compare type=-list required) + (compare type=-list optional)) + (if (or (args-type-keyp type1) (args-type-keyp type2)) + (values (compare-key-args type1 type2) t) + (values t t)))))) + +;;; Do a union or intersection operation on types that might be values +;;; types. The result is optimized for utility rather than exactness, +;;; but it is guaranteed that it will be no smaller (more restrictive) +;;; than the precise result. +;;; +;;; The return convention seems to be analogous to +;;; TYPES-EQUAL-OR-INTERSECT. -- WHN 19990910. +(defun-cached (values-type-union :hash-function #'type-cache-hash + :hash-bits 8) + ((type1 eq) (type2 eq)) + (declare (type ctype type1 type2)) + (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*) + ((eq type1 *empty-type*) type2) + ((eq type2 *empty-type*) type1) + (t + (values (values-type-op type1 type2 #'type-union #'min))))) + +(defun-cached (values-type-intersection :hash-function #'type-cache-hash + :hash-bits 8) + ((type1 eq) (type2 eq)) + (declare (type ctype type1 type2)) + (cond ((eq type1 *wild-type*) + (coerce-to-values type2)) + ((or (eq type2 *wild-type*) (eq type2 *universal-type*)) + type1) + ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) + *empty-type*) + ((and (not (values-type-p type2)) + (values-type-required type1)) + (let ((req1 (values-type-required type1))) + (make-values-type :required (cons (type-intersection (first req1) type2) + (rest req1)) + :optional (values-type-optional type1) + :rest (values-type-rest type1) + :allowp (values-type-allowp type1)))) + (t + (values (values-type-op type1 (coerce-to-values type2) + #'type-intersection + #'max))))) + +;;; This is like TYPES-EQUAL-OR-INTERSECT, except that it sort of +;;; works on VALUES types. Note that due to the semantics of +;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when +;;; there isn't really any intersection. +(defun values-types-equal-or-intersect (type1 type2) + (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) + (values t t)) + ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) + (values t t)) + (t + (let ((res (values-type-intersection type1 type2))) + (values (not (eq res *empty-type*)) + t))))) + +;;; a SUBTYPEP-like operation that can be used on any types, including +;;; VALUES types +(defun-cached (values-subtypep :hash-function #'type-cache-hash + :hash-bits 8 + :values 2) + ((type1 eq) (type2 eq)) + (declare (type ctype type1 type2)) + (cond ((or (eq type2 *wild-type*) (eq type2 *universal-type*) + (eq type1 *empty-type*)) + (values t t)) + ((eq type1 *wild-type*) + (values (eq type2 *wild-type*) t)) + ((or (eq type2 *empty-type*) + (not (values-types-equal-or-intersect type1 type2))) + (values nil t)) + ((and (not (values-type-p type2)) + (values-type-required type1)) + (csubtypep (first (values-type-required type1)) + type2)) + (t (setq type2 (coerce-to-values type2)) + (multiple-value-bind (types1 rest1) (values-type-types type1) + (multiple-value-bind (types2 rest2) (values-type-types type2) + (cond ((< (length (values-type-required type1)) + (length (values-type-required type2))) + (values nil t)) + ((< (length types1) (length types2)) + (values nil nil)) + (t + (do ((t1 types1 (rest t1)) + (t2 types2 (rest t2))) + ((null t2) + (loop named loop + for type in t1 + do (multiple-value-bind (res win) + (csubtypep type rest2) + (unless win + (return (values nil nil))) + (unless res + (return (values nil t))))) + (csubtypep rest1 rest2)) + (multiple-value-bind (res win-p) + (csubtypep (first t1) (first t2)) + (unless win-p + (return (values nil nil))) + (unless res + (return (values nil t)))))))))))) + +;;;; type method interfaces + +;;; like SUBTYPEP, only works on CTYPE structures +(defun-cached (csubtypep :hash-function #'type-cache-hash + :hash-bits 10 + :memoizer memoize + :values 2) + ((type1 eq) (type2 eq)) + (declare (type ctype type1 type2)) + (cond ((or (eq type1 type2) + (eq type1 *empty-type*) + (eq type2 *universal-type*)) + (values t t)) + #+nil + ((eq type1 *universal-type*) + (values nil t)) + (t + (memoize + (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1))))) + +;;; Just parse the type specifiers and call CSUBTYPE. +;;; Well, not "just" - Despite memoization of parsing and CSUBTYPEP, +;;; it's nonetheless better to test EQUAL first, which is ~10x faster +;;; in the positive case, and insigificant in the negative. +;;; The specifiers might not be legal type specifiers, +;;; but we're not obligated to police that: +;;; "This version eliminates the requirement to signal an error." +;;; http://www.lispworks.com/documentation/HyperSpec/Issues/iss335_w.htm +;;; (Status: Passed, as amended, Jun89 X3J13) +;;; +;;; Also, inferring from the version of the text that was obsoleted +;;; - which while it has no direct impact on the final requirement, +;;; implies something about what would have been legal - +;;; "SUBTYPEP must always return values T T in the case where the two +;;; type specifiers (or their expansions) are EQUAL." +;;; i.e. though it is not longer technically a MUST, it suggests that EQUAL is +;;; in fact a valid implementation, at least where it computes T. +(defun subtypep (type1 type2 &optional environment) + "Return two values indicating the relationship between type1 and type2. + If values are T and T, type1 definitely is a subtype of type2. + If values are NIL and T, type1 definitely is not a subtype of type2. + If values are NIL and NIL, it couldn't be determined." + (declare (type lexenv-designator environment) (ignore environment)) + (declare (explicit-check)) + (if (equal type1 type2) + (values t t) + (csubtypep (specifier-type type1) (specifier-type type2)))) + +(declaim (inline ctype-eq-comparable)) +(defun ctype-eq-comparable (ctype) + (logtest (type-hash-value ctype) +type-admits-type=-optimization+)) + +(defun ctype-interned-p (ctype) + (logtest (type-hash-value ctype) +type-internedp+)) + +(declaim (start-block)) + +;;; If two types are definitely equivalent, return true. The second +;;; value indicates whether the first value is definitely correct. +;;; This should only fail in the presence of HAIRY types. +(defun-cached (type= :hash-function #'type-cache-hash + :hash-bits 11 + :memoizer memoize + :values 2) + ((type1 eq) (type2 eq)) + (declare (type ctype type1 type2)) + (cond ((eq type1 type2) + (values t t)) + ;; If args are not EQ, but both allow TYPE= optimization, + ;; and at least one is interned, then return no and certainty. + ;; Most of the interned CTYPEs admit this optimization, + ;; NUMERIC and MEMBER types do as well. + ((and (logtest +type-internedp+ + (logior (type-hash-value type1) (type-hash-value type2))) + (logtest +type-admits-type=-optimization+ + (logand (type-hash-value type1) (type-hash-value type2)))) + (values nil t)) + (t + (memoize (!invoke-type-method :simple-= :complex-= type1 type2))))) + +;;; Not exactly the negation of TYPE=, since when the relationship is +;;; uncertain, we still return NIL, NIL. This is useful in cases where +;;; the conservative assumption is =. +(defun type/= (type1 type2) + (declare (type ctype type1 type2)) + (multiple-value-bind (res win) (type= type1 type2) + (if win + (values (not res) t) + (values nil nil)))) + +(declaim (end-block)) + +;;; the type method dispatch case of TYPE-UNION2 +(defun %type-union2 (type1 type2) + ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give + ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike + ;; %TYPE-INTERSECTION2, though, I don't have a specific case which + ;; demonstrates this is actually necessary. Also unlike + ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish + ;; between not finding a method and having a method return NIL. + (flet ((1way (x y) + (!invoke-type-method :simple-union2 :complex-union2 + x y + :default nil))) + (declare (inline 1way)) + (or (1way type1 type2) + (1way type2 type1)))) + +;;; Find a type which includes both types. Any inexactness is +;;; represented by the fuzzy element types; we return a single value +;;; that is precise to the best of our knowledge. This result is +;;; simplified into the canonical form, thus is not a UNION-TYPE +;;; unless we find no other way to represent the result. +(defun-cached (type-union2 :hash-function #'type-cache-hash + :hash-bits 11 + :memoizer memoize) + ((type1 eq) (type2 eq)) + ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And + ;; Paste technique of programming. If it stays around (as opposed to + ;; e.g. fading away in favor of some CLOS solution) the shared logic + ;; should probably become shared code. -- WHN 2001-03-16 + (declare (type ctype type1 type2)) + (let ((t2 nil)) + (if (eq type1 type2) + type1 + (memoize + (cond + ;; CSUBTYPEP for array-types answers questions about the + ;; specialized type, yet for union we want to take the + ;; expressed type in account too. + ((and (not (and (array-type-p type1) (array-type-p type2))) + (or (setf t2 (csubtypep type1 type2)) + (csubtypep type2 type1))) + (if t2 type2 type1)) + ((or (union-type-p type1) + (union-type-p type2)) + ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES + ;; values broken out and united separately. The full TYPE-UNION + ;; function knows how to do this, so let it handle it. + (type-union type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-union2 type1 type2))))))) + +;;; the type method dispatch case of TYPE-INTERSECTION2 +(defun %type-intersection2 (type1 type2) + ;; We want to give both argument orders a chance at + ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type + ;; methods could give noncommutative results, e.g. + ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE) + ;; => NIL, NIL + ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*) + ;; => #, T + ;; We also need to distinguish between the case where we found a + ;; type method, and it returned NIL, and the case where we fell + ;; through without finding any type method. An example of the first + ;; case is the intersection of a HAIRY-TYPE with some ordinary type. + ;; An example of the second case is the intersection of two + ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and + ;; ARRAY. + ;; + ;; (Why yes, CLOS probably *would* be nicer..) + (flet ((1way (x y) + (!invoke-type-method :simple-intersection2 :complex-intersection2 + x y + :default :call-other-method))) + (declare (inline 1way)) + (let ((xy (1way type1 type2))) + (or (and (not (eql xy :call-other-method)) xy) + (let ((yx (1way type2 type1))) + (or (and (not (eql yx :call-other-method)) yx) + (cond ((and (eql xy :call-other-method) + (eql yx :call-other-method)) + *empty-type*) + (t + nil)))))))) + +(defun-cached (type-intersection2 :hash-function #'type-cache-hash + :hash-bits 11 + :memoizer memoize + :values 1) + ((type1 eq) (type2 eq)) + (declare (type ctype type1 type2)) + (if (eq type1 type2) + ;; FIXME: For some reason, this doesn't catch e.g. type1 = + ;; type2 = (SPECIFIER-TYPE + ;; 'SOME-UNKNOWN-TYPE). Investigate. - CSR, 2002-04-10 + type1 + (memoize + (cond + ((or (intersection-type-p type1) + (intersection-type-p type2)) + ;; Intersections of INTERSECTION-TYPE should have the + ;; INTERSECTION-TYPE-TYPES values broken out and intersected + ;; separately. The full TYPE-INTERSECTION function knows how + ;; to do that, so let it handle it. + (type-intersection type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-intersection2 type1 type2)))))) + +;;; Return as restrictive and simple a type as we can discover that is +;;; no more restrictive than the intersection of TYPE1 and TYPE2. At +;;; worst, we arbitrarily return one of the arguments as the first +;;; value (trying not to return a hairy type). +(defun type-approx-intersection2 (type1 type2) + (cond ((type-intersection2 type1 type2)) + ((hairy-type-p type1) type2) + (t type1))) + +;;; a test useful for checking whether a derived type matches a +;;; declared type +;;; +;;; The first value is true unless the types don't intersect and +;;; aren't equal. The second value is true if the first value is +;;; definitely correct. NIL is considered to intersect with any type. +;;; If T is a subtype of either type, then we also return T, T. This +;;; way we recognize that hairy types might intersect with T. +;;; +;;; Well now given the statement above that this is "useful for ..." +;;; a particular thing, I see how treating *empty-type* magically could +;;; be useful, however given all the _other_ calls to this function within +;;; this file, it seems suboptimal, because logically it is wrong. +(defun types-equal-or-intersect (type1 type2) + (declare (type ctype type1 type2)) + (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) + (values t t) + (let ((intersection2 (type-intersection2 type1 type2))) + (cond ((not intersection2) + (if (or (csubtypep *universal-type* type1) + (csubtypep *universal-type* type2)) + (values t t) + (values t nil))) + ((eq intersection2 *empty-type*) (values nil t)) + (t (values t t)))))) + +;;; Return a Common Lisp type specifier corresponding to the TYPE +;;; object. +(defun type-specifier (type) + (declare (type ctype type)) + (funcall (type-class-unparse (type-class type)) type)) + + +;;; Return the type structure corresponding to a type specifier. +;;; +;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a +;;; type is defined (or redefined). +;;; +;;; As I understand things, :FORTHCOMING-DEFCLASS-TYPE behaves contrarily +;;; to the CLHS intent, which is to make the type known to the compiler. +;;; If we compile in one file: +;;; (DEFCLASS FRUITBAT () ()) +;;; (DEFUN FRUITBATP (X) (TYPEP X 'FRUITBAT)) +;;; we see that it emits a call to %TYPEP with the symbol FRUITBAT as its +;;; argument, whereas it should involve CLASSOID-CELL-TYPEP and LAYOUT-OF, +;;; which (correctly) signals an error if the class were not defined by the +;;; time of the call. Delayed re-parsing of FRUITBAT into any random specifier +;;; at call time is wrong. +;;; +;;; FIXME: symbols which are :PRIMITIVE are inconsistently accepted as singleton +;;; lists. e.g. (BIT) and (ATOM) are considered legal, but (FIXNUM) and +;;; (CHARACTER) are not. It has to do with whether the primitive is actually +;;; a DEFTYPE. The CLHS glossary implies that the singleton is *always* legal. +;;; "For every atomic type specifier, x, there is an _equivalent_ [my emphasis] +;;; compound type specifier with no arguments supplied, (x)." +;;; By that same reasonining, is (x) accepted if x names a class? +;;; + +;;; The xc host uses an ordinary hash table for memoization. +#+sb-xc-host +(let ((table (make-hash-table :test 'equal))) + (defun !values-specifier-type-memo-wrapper (thunk specifier) + (multiple-value-bind (type yesp) (gethash specifier table) + (if yesp + type + (setf (gethash specifier table) (funcall thunk))))) + (defun values-specifier-type-cache-clear () + (clrhash table))) +;;; This cache is sized extremely generously, which has payoff +;;; elsewhere: it improves the TYPE= and CSUBTYPEP functions, +;;; since EQ types are an immediate win. +#-sb-xc-host +(sb-impl::!define-hash-cache values-specifier-type + ((orig equal-but-no-car-recursion)) () + :hash-function #'sxhash :hash-bits 10) + +(declaim (inline make-type-context)) +(defstruct (type-context + (:constructor make-type-context + (spec &optional proto-classoid (options 0))) + (:copier nil) + (:predicate nil)) + (spec nil :read-only t) + (proto-classoid nil :read-only t) + (options 0 :type fixnum)) +(defconstant +type-parse-cache-inhibit+ 1) +(defconstant +type-parse-signal-inhibit+ 2) +(defmacro type-context-cacheable (x) + `(not (logtest (type-context-options ,x) +type-parse-cache-inhibit+))) + +;;; Maintain a table of symbols designating unknown types that have any references +;;; to them, making it easy to inquire whether such things exist. This is at a lower +;;; layer than the parser cache - it's a cache of the constructor itself - so we'll +;;; sitll signal that an unknown specifier is unknown on each reparse of the same. +;;; But as long as any reference enlivens the relevant CTYPE, we'll return that object. +(defglobal **unknown-type-atoms** + ;; This table is specified as unsynchronized because we need to wrap the lock + ;; around a read/modify/write. GETHASH and PUTHASH can't do that themselves. + (sb-impl::make-system-hash-table :test 'eq :weakness :value :synchronized nil)) + +#-sb-xc-host +(progn (declaim (inline class-classoid)) + (defun class-classoid (class) + (wrapper-classoid (sb-pcl::class-wrapper class)))) + +;;; Parsing of type specifiers comes in many variations: +;;; SINGLE-VALUE-SPECIFIER-TYPE: +;;; disallow VALUES even if single value, but allow * +;;; SPECIFIER-TYPE: +;;; disallow (VALUES ...) even if single value, and disallow * +;;; VALUES-SPECIFIER-TYPE: +;;; allow VALUES, disallow * +;;; TYPE-OR-NIL-IF-UNKNOWN: +;;; like SPECIFIER-TYPE, but return NIL if contains unknown +;;; all the above are funneled through BASIC-PARSE-TYPESPEC. + +;;; The recursive %PARSE-TYPE function is used for nested invocations +;;; of type spec parsing, passing the outermost context through on each call. +;;; Callers should use the BASIC-PARSE-TYPESPEC interface. + +;;; Hint for when you bork this and/or bork the :UNPARSE methods - do: +;;; (remove-method #'print-object (find-method #'print-object nil +;;; (list (find-class 'ctype) (find-class 't)))) +;;; so that 'backtrace' doesn't encounter an infinite chain of errors. + +(macrolet ((fail (spec) + `(error "bad thing to be a type specifier: ~/sb-impl:print-type-specifier/" + ,spec))) +(defun %parse-type (spec context) + (declare (type type-context context)) + (prog* ((head (if (listp spec) (car spec) spec)) + (builtin (if (symbolp head) + (info :type :builtin head) + (return (fail spec))))) + (when (deprecated-thing-p 'type head) + (setf (type-context-options context) + (logior (type-context-options context) +type-parse-cache-inhibit+)) + (signal 'parse-deprecated-type :specifier spec)) + (when (atom spec) + ;; If spec is non-atomic, the :BUILTIN value is inapplicable. + ;; There used to be compound builtins, but not any more. + (when builtin (return builtin)) + ;; Any spec that apparently refers to a defstruct form + ;; that's being macroexpanded should refer to that type. + (awhen (type-context-proto-classoid context) + (when (eq (classoid-name it) spec) (return it))) + (case (info :type :kind spec) + (:instance (return (find-classoid spec))) + (:forthcoming-defclass-type (go unknown)))) + ;; Expansion brings up an interesting question - should the cache + ;; contain entries for intermediary types? Say A -> B -> REAL. + ;; As it stands, we cache the ctype corresponding to A but not B. + (awhen (info :type :expander head) + (when (listp it) ; The function translates directly to a CTYPE. + (return (or (funcall (car it) context spec) (fail spec)))) + ;; The function produces a type expression. + (let ((expansion (funcall it (ensure-list spec)))) + (return (if (typep expansion 'instance) + (basic-parse-typespec expansion context) + (%parse-type expansion context))))) + ;; If the spec is (X ...) and X has neither a translator + ;; nor expander, and is a builtin, such as FIXNUM, fail now. + ;; But - see FIXME at top - it would be consistent with + ;; DEFTYPE to reject spec only if not a singleton. + (when builtin (return (fail spec))) + ;; SPEC has a legal form, so return an unknown type. + (unless (logtest (type-context-options context) +type-parse-signal-inhibit+) + (signal 'parse-unknown-type :specifier spec)) + UNKNOWN + (setf (type-context-options context) + (logior (type-context-options context) +type-parse-cache-inhibit+)) + (return (if (atom spec) + (let ((table **unknown-type-atoms**)) + (with-system-mutex ((hash-table-lock table)) + (or (gethash spec table) + (progn #+sb-xc-host + (when cl:*compile-print* + (format t "~&; NEW UNKNOWN-TYPE ~S~%" spec)) + (setf (gethash spec table) + (make-unknown-type :specifier spec)))))) + (make-unknown-type :specifier spec))))) + +;;; BASIC-PARSE-TYPESPEC can grok some simple cases that involve turning an object +;;; used as a type specifier into an internalized type object (which might be +;;; the selfsame object, in the case of a CLASSOID). +(defun basic-parse-typespec (type-specifier context) + (declare (type type-context context)) + (when (typep type-specifier 'instance) + ;; An instance never needs the type parser cache, because it almost always + ;; represents itself or a slot in itself. + (flet ((classoid-to-ctype (classoid) + ;; A few classoids have translations, + ;; e.g. the classoid CONS is a CONS-TYPE. + ;; Hmm, perhaps this should signal PARSE-UNKNOWN-TYPE + ;; if CLASSOID is an instance of UNDEFINED-CLASSOID ? + ;; Can that happen? + (or (and (built-in-classoid-p classoid) + (built-in-classoid-translation classoid)) + classoid))) + (return-from basic-parse-typespec + (cond ((classoid-p type-specifier) (classoid-to-ctype type-specifier)) + ;; Avoid TYPEP on SB-MOP:EQL-SPECIALIZER and CLASS because + ;; the fake metaobjects do not allow type analysis, and + ;; would cause a compiler error as it tries to decide + ;; whether any clause of this COND subsumes another. + ;; Moreover, we don't require the host to support MOP. + #-sb-xc-host + ((sb-pcl::classp type-specifier) + ;; A CLOS class is translated to its CLASSOID, or the classoid's translation. + (classoid-to-ctype (sb-pcl::class-classoid type-specifier))) + #-sb-xc-host + ((sb-pcl::eql-specializer-p type-specifier) + ;; EQL specializers are are seldom used and not 100% portable, + ;; though they are part of the AMOP. + ;; See https://sourceforge.net/p/sbcl/mailman/message/11217378/ + ;; We implement the notion that an EQL-SPECIALIZER has-a CTYPE. + ;; You might think that a cleverer way would be to say that + ;; EQL-SPECIALIZER is-a CTYPE, i.e. incorporating EQL-SPECIALIZER + ;; objects into the type machinary. Well, that's a problem - + ;; it would mess up admissibility of the TYPE= optimization. + ;; We don't want to create another way of representing + ;; the type NULL = (MEMBER NIL), for example. + (sb-pcl::eql-specializer-to-ctype type-specifier)) + ((wrapper-p type-specifier) + (wrapper-classoid type-specifier)) + (t (fail type-specifier)))))) + (when (atom type-specifier) + ;; Try to bypass the cache, which avoids using a cache line for standard + ;; atomic specifiers. This is a trade-off- cache seek might be faster, + ;; but this solves the problem that a full call to (TYPEP #\A 'FIXNUM) + ;; consed a cache line every time the cache missed on FIXNUM (etc). + (awhen (info :type :builtin type-specifier) + (return-from basic-parse-typespec it))) + + ;; If CONTEXT was non-cacheable as supplied, the cache is bypassed + ;; for any nested lookup, and we don't insert the result. + (if (not (type-context-cacheable context)) + (%parse-type (uncross type-specifier) context) + ;; Otherwise, try for a cache hit first, and usually update the cache. + (!values-specifier-type-memo-wrapper + (lambda () + (let ((answer (%parse-type (uncross type-specifier) context))) + (if (type-context-cacheable context) + answer + ;; Lookup was cacheable, but result isn't. + ;; Non-caching ensures that we see every occurrence of an unknown + ;; type no matter how deeply nested it is in the expression. + ;; e.g. (OR UNKNOWN-FOO CONS) and (OR INTEGER UNKNOWN-FOO) + ;; should both signal the PARSE-UNKNOWN condition, which would + ;; not happen if the first cached UNKNOWN-FOO. + + ;; During make-host-2 I'm seeing the types &OPTIONAL-AND-&KEY-IN-LAMBDA-LIST, + ;; SIMPLE-ERROR, DISASSEM-STATE as non-cacheable, + ;; and much, much more during make-target-2. + ;; The condition types are obvious, because we mention them before + ;; defining them. + ;; DISASSEM-STATE comes from building **TYPE-SPEC-INTERR-SYMBOLS** + ;; where we have a fixed list of types which get assigned single-byte + ;; error codes. + (progn + #+nil + (unless (type-context-cacheable context) + (format t "~&non-cacheable: ~S ~%" type-specifier)) + (return-from basic-parse-typespec answer))))) + type-specifier))) +) ; end MACROLET + +;;; This takes no CONTEXT (which implies lack of recursion) because +;;; you can't reasonably place a VALUES type inside another type. +(defun values-specifier-type (type-specifier) + ;; This catches uses of literal '* where it shouldn't appear, but it + ;; accidentally lets other uses slip through. We'd have to catch '* + ;; post-type-expansion to be more strict, but it isn't very important. + (cond ((eq type-specifier '*) + (warn "* is not permitted as a type specifier") + *universal-type*) + (t + (dx-let ((context (make-type-context type-specifier))) + (basic-parse-typespec type-specifier context))))) + +;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to +;;; never return a VALUES type. +;;; CONTEXT is either an instance of TYPE-CONTEXT or NIL. +;;; SUBCONTEXT is a symbol denoting the head of the current expression, or NIL. +(defun specifier-type (type-specifier &optional context subcontext) + (let* ((ctype + (if context + (basic-parse-typespec type-specifier context) + (dx-let ((context (make-type-context type-specifier))) + (basic-parse-typespec type-specifier context)))) + (wildp (eq ctype *wild-type*))) + ;; We have to see how it was spelled to give an intelligent message. + ;; If it's instance of VALUES-TYPE, then it was spelled as VALUES + ;; whereas if it isn't, the user either spelled it as (VALUES) or *. + ;; The case where this heuristic doesn't work is a DEFTYPE that expands + ;; to *, but that's not worth worrying about. + (cond ((or (values-type-p ctype) + (and wildp (consp type-specifier))) + (error "VALUES type illegal in this context:~% ~ + ~/sb-impl:print-type-specifier/" + type-specifier)) + (wildp + (when context + (setf (type-context-options context) + (logior (type-context-options context) + +type-parse-cache-inhibit+))) + (if subcontext + (warn "* is not permitted as an argument to the ~S type specifier" + subcontext) + (warn "* is not permitted as a type specifier~@[ in the context ~S~]" + ;; If the entire surrounding context is * then there's not much + ;; else to say. Otherwise, show the original expression. + (when (and context (neq (type-context-spec context) '*)) + (type-context-spec context)))) + *universal-type*) + (t + ctype)))) + +(defun single-value-specifier-type (x &optional context) + (if (eq x '*) + *universal-type* + (specifier-type x context))) + +;;; When cross-compiling SPECIFIER-TYPE with a quoted argument, +;;; it can be rendered as a literal object unless it mentions +;;; certain classoids. +;;; +;;; This is important for type system initialization. +;;; +;;; After the target is built, we remove this transform, both because calls +;;; to SPECIFIER-TYPE do not arise organically through user code, +;;; and because it is possible that user changes to types could make parsing +;;; return a different thing, e.g. changing a DEFTYPE to a DEFCLASS. +;;; +#+sb-xc-host +(labels ((xform (type-spec env parser) + (if (not (constantp type-spec env)) + (values nil t) + (let* ((expr (constant-form-value type-spec env)) + (parse (funcall parser expr))) + (if (cold-dumpable-type-p parse) + parse + (values nil t))))) + (cold-dumpable-type-p (ctype) + (when (contains-unknown-type-p ctype) + (bug "SPECIFIER-TYPE transform parsed an unknown type: ~S" ctype)) + (map-type (lambda (type) + (when (and (classoid-p type) (eq (classoid-name type) 'class)) + (return-from cold-dumpable-type-p nil))) + ctype) + t)) + (sb-c:define-source-transform specifier-type (type-spec &environment env) + (xform type-spec env #'specifier-type)) + (sb-c:define-source-transform values-specifier-type (type-spec &environment env) + (xform type-spec env #'values-specifier-type))) + +(defun typexpand-1 (type-specifier &optional env) + "Takes and expands a type specifier once like MACROEXPAND-1. +Returns two values: the expansion, and a boolean that is true when +expansion happened." + (declare (type type-specifier type-specifier)) + (declare (type lexenv-designator env) (ignore env)) + (let* ((spec type-specifier) + (atom (if (listp spec) (car spec) spec)) + (expander (and (symbolp atom) (info :type :expander atom)))) + ;; We do not expand builtins even though it'd be + ;; possible to do so sometimes (e.g. STRING) for two + ;; reasons: + ;; + ;; a) From a user's point of view, CL types are opaque. + ;; + ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING)) + (if (and (functionp expander) (not (info :type :builtin atom))) + (values (funcall expander (if (symbolp spec) (list spec) spec)) t) + (values type-specifier nil)))) + +(defun typexpand (type-specifier &optional env) + "Takes and expands a type specifier repeatedly like MACROEXPAND. +Returns two values: the expansion, and a boolean that is true when +expansion happened." + ;; TYPE-SPECIFIER is of type TYPE-SPECIFIER, but it is preferable to + ;; defer to TYPEXPAND-1 for the typecheck. Similarly for ENV. + (multiple-value-bind (expansion expanded) + (typexpand-1 type-specifier env) + (if expanded + (values (typexpand expansion env) t) + (values expansion expanded)))) + +;;; Take a list of type specifiers, computing the translation of each +;;; specifier and defining it as a builtin type. +;;; Seee the comments in 'type-init' for why this is a slightly +;;; screwy way to go about it. +(declaim (ftype (function (list) (values)) !precompute-types)) +(defun !precompute-types (specs) + (dolist (spec specs) + (let ((res (handler-bind + ((parse-unknown-type + (lambda (c) + (declare (ignore c)) + ;; We can handle conditions at this point, + ;; but win32 can not perform i/o here because + ;; !MAKE-COLD-STDERR-STREAM has no implementation. + ;; FIXME: where is this coming from??? + #+nil + (progn (write-string "//caught: parse-unknown ") + (write spec) + (terpri))))) + (specifier-type spec)))) + (unless (unknown-type-p res) + (setf (info :type :builtin spec) res) + (setf (info :type :kind spec) :primitive)))) + (values)) + +;;; Parse TYPE-SPECIFIER, returning NIL if any sub-part of it is unknown +(defun type-or-nil-if-unknown (type-specifier &optional allow-values) + (dx-let ((context (make-type-context type-specifier))) + (let ((result (if allow-values + (basic-parse-typespec type-specifier context) + (specifier-type type-specifier context)))) + ;; If it was non-cacheable, either it contained a deprecated type + ;; or unknown type, or was a pending defstruct definition. + (if (and (not (type-context-cacheable context)) + (contains-unknown-type-p result)) + nil + result)))) + +(defun-cached (type-negation :hash-function #'type-hash-value + :hash-bits 8 + :values 1) + ((type eq)) + (declare (type ctype type)) + (funcall (type-class-negate (type-class type)) type)) + +(defun-cached (type-singleton-p :hash-function #'type-hash-value + :hash-bits 8 + :values 2) + ((type eq)) + (declare (type ctype type)) + (let ((function (type-class-singleton-p (type-class type)))) + (if function + (funcall function type) + (values nil nil)))) + + +;;;; general TYPE-UNION and TYPE-INTERSECTION operations +;;;; +;;;; These are fully general operations on CTYPEs: they'll always +;;;; return a CTYPE representing the result. + +;;; shared logic for unions and intersections: Return a list of +;;; types representing the same types as INPUT-TYPES, but with +;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their +;;; component types, and with any SIMPLY2 simplifications applied. +(macrolet + ((def (name compound-type-p simplify2) + `(defun ,name (types) + (when types + (multiple-value-bind (first rest) + (if (,compound-type-p (car types)) + (values (car (compound-type-types (car types))) + (append (cdr (compound-type-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (,name rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (,simplify2 first r)) + (return (,name (nsubstitute u r rest))))))))))) + (def simplify-intersections intersection-type-p type-intersection2) + (def simplify-unions union-type-p type-union2)) + +(defun maybe-distribute-one-union (union-type types) + (let* ((intersection (%type-intersection types)) + (union (mapcar (lambda (x) (type-intersection x intersection)) + (union-type-types union-type)))) + (if (notany (lambda (x) (or (hairy-type-p x) + (intersection-type-p x))) + union) + union + nil))) + +(defun type-intersection (&rest input-types) + (%type-intersection input-types)) +(defun-cached (%type-intersection :hash-bits 10 :hash-function #'type-list-cache-hash) + ((input-types equal)) + (let ((simplified-types (simplify-intersections input-types))) + (declare (type list simplified-types)) + ;; We want to have a canonical representation of types (or failing + ;; that, punt to HAIRY-TYPE). Canonical representation would have + ;; intersections inside unions but not vice versa, since you can + ;; always achieve that by the distributive rule. But we don't want + ;; to just apply the distributive rule, since it would be too easy + ;; to end up with unreasonably huge type expressions. So instead + ;; we try to generate a simple type by distributing the union; if + ;; the type can't be made simple, we punt to HAIRY-TYPE. + (if (and (cdr simplified-types) (some #'union-type-p simplified-types)) + (let* ((first-union (find-if #'union-type-p simplified-types)) + (other-types (coerce (remove first-union simplified-types) + 'list)) + (distributed (maybe-distribute-one-union first-union + other-types))) + (if distributed + (%type-union distributed) + (%make-hairy-type `(and ,@(map 'list #'type-specifier + simplified-types))))) + (cond + ((null simplified-types) *universal-type*) + ((null (cdr simplified-types)) (car simplified-types)) + (t (%make-intersection-type + (some #'type-enumerable simplified-types) + simplified-types)))))) + +(defun type-union (&rest input-types) + (%type-union input-types)) +(defun-cached (%type-union :hash-bits 8 :hash-function #'type-list-cache-hash) + ((input-types equal)) + (let ((simplified-types (simplify-unions input-types))) + (cond + ((null simplified-types) *empty-type*) + ((null (cdr simplified-types)) (car simplified-types)) + (t (make-union-type + (every #'type-enumerable simplified-types) + simplified-types))))) + +;;;; built-in types + +(define-type-method (named :simple-=) (type1 type2) + ;;(aver (not (eq type1 *wild-type*))) ; * isn't really a type. + (values (eq type1 type2) t)) + +(defun cons-type-might-be-empty-type (type) + (declare (type cons-type type)) + (let ((car-type (cons-type-car-type type)) + (cdr-type (cons-type-cdr-type type))) + (or + (if (cons-type-p car-type) + (cons-type-might-be-empty-type car-type) + (multiple-value-bind (yes surep) + (type= car-type *empty-type*) + (aver (not yes)) + (not surep))) + (if (cons-type-p cdr-type) + (cons-type-might-be-empty-type cdr-type) + (multiple-value-bind (yes surep) + (type= cdr-type *empty-type*) + (aver (not yes)) + (not surep)))))) + +(defun cons-type-length-info (type) + (declare (type cons-type type)) + (do ((min 1 (1+ min)) + (cdr (cons-type-cdr-type type) (cons-type-cdr-type cdr))) + ((not (cons-type-p cdr)) + (cond + ((csubtypep cdr (specifier-type 'null)) + (values min t)) + ((csubtypep *universal-type* cdr) + (values min nil)) + ((type/= (type-intersection (specifier-type 'cons) cdr) *empty-type*) + (values min nil)) + ((type/= (type-intersection (specifier-type 'null) cdr) *empty-type*) + (values min t)) + (t (values min :maybe)))) + ())) + +(define-type-method (named :complex-=) (type1 type2) + (cond + ((and (eq type2 *empty-type*) + (or (and (intersection-type-p type1) + ;; not allowed to be unsure on these... FIXME: keep + ;; the list of CL types that are intersection types + ;; once and only once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) + (and (cons-type-p type1) + (cons-type-might-be-empty-type type1)))) + ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION + ;; STREAM) can get here. In general, we can't really tell + ;; whether these are equal to NIL or not, so + (values nil nil)) + ((type-might-contain-other-types-p type1) + (invoke-complex-=-other-method type1 type2)) + (t (values nil t)))) + +(define-type-method (named :simple-subtypep) (type1 type2) + (aver (not (eq type1 *wild-type*))) ; * isn't really a type. + (aver (not (eq type1 type2))) + (values (or (eq type1 *empty-type*) + (eq type2 *wild-type*) + (eq type2 *universal-type*)) t)) + +(define-type-method (named :complex-subtypep-arg1) (type1 type2) + ;; This AVER causes problems if we write accurate methods for the + ;; union (and possibly intersection) types which then delegate to + ;; us; while a user shouldn't get here, because of the odd status of + ;; *wild-type* a type-intersection executed by the compiler can. - + ;; CSR, 2002-04-10 + ;; + ;; (aver (not (eq type1 *wild-type*))) ; * isn't really a type. + (cond ((eq type1 *empty-type*) + t) + (;; When TYPE2 might be the universal type in disguise + (type-might-contain-other-types-p type2) + ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods + ;; can delegate to us (more or less as CALL-NEXT-METHOD) when + ;; they're uncertain, we can't just barf on COMPOUND-TYPE and + ;; HAIRY-TYPEs as we used to. Instead we deal with the + ;; problem (where at least part of the problem is cases like + ;; (SUBTYPEP T '(SATISFIES FOO)) + ;; or + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) + ;; where the second type is a hairy type like SATISFIES, or + ;; is a compound type which might contain a hairy type) by + ;; returning uncertainty. + (values nil nil)) + ((eq type1 *funcallable-instance-type*) + (values (eq type2 (specifier-type 'function)) t)) + (t + ;; This case would have been picked off by the SIMPLE-SUBTYPEP + ;; method, and so shouldn't appear here. + (aver (not (named-type-p type2))) + ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not another + ;; named type in disguise, TYPE2 is not a superset of TYPE1. + (values nil t)))) + +;;; Return T if members of this classoid certainly have INSTANCE-POINTER-LOWTAG. +;;; Logically it is the near opposite of CLASSOID-NON-INSTANCE-P, but not quite. +;;; CTYPEs which are not represented as a classoid return NIL for both predicates +;;; as do PCL types which may be either funcallable or non-funcallable. +;;; +;;; But some of that generality seems wrong. I don't think it would be allowed +;;; to have (as merely an example) an EQL-SPECIALIZER which is funcallable, +;;; having FUN-POINTER-LOWTAG instead of INSTANCE-POINTER-LOWTAG). Yet we think +;;; it could happen, because the parse of the type (AND EQL-SPECIALIZER INSTANCE) +;;; yields # +;;; versus simplifying down to EQL-SPECIALIZER. +#| (loop for c being each hash-key of (classoid-subclasses (find-classoid 't)) + do (let ((not-i (classoid-non-instance-p c)) + (i (classoid-definitely-instancep c))) + (unless (eq (not not-i) i) (format t "~S -> ~A and ~A~%" c not-i i)))) |# +(defun classoid-definitely-instancep (x) + (or (structure-classoid-p x) + (condition-classoid-p x) + ;; PATHNAMEs are INSTANCEs based on the lowtag criterion + (or (eq x (specifier-type 'logical-pathname)) + (eq x (specifier-type 'pathname))))) +(eval-when (:compile-toplevel :execute) + (pushnew 'classoid-definitely-instancep sb-vm::*backend-cross-foldable-predicates*)) + +(defun classoid-is-or-inherits (sub super) + (or (classoid-inherits-from sub super) + (eq sub (find-classoid super)))) + +(define-type-method (named :complex-subtypep-arg2) (type1 type2) + (aver (not (eq type2 *wild-type*))) ; * isn't really a type. + (cond ((eq type2 *universal-type*) + (values t t)) + ;; some CONS types can conceal danger + ((and (cons-type-p type1) (cons-type-might-be-empty-type type1)) + (values nil nil)) + ((type-might-contain-other-types-p type1) + ;; those types can be other types in disguise. So we'd + ;; better delegate. + (invoke-complex-subtypep-arg1-method type1 type2)) + ((and (or (eq type2 *instance-type*) + (eq type2 *funcallable-instance-type*)) + (member-type-p type1)) + ;; member types can be subtypep INSTANCE and + ;; FUNCALLABLE-INSTANCE in surprising ways. + (invoke-complex-subtypep-arg1-method type1 type2)) + ((and (eq type2 *extended-sequence-type*) (classoid-p type1)) + (values (if (classoid-inherits-from type1 'sequence) t nil) t)) + ((and (eq type2 *instance-type*) (classoid-p type1)) + (cond ((or (classoid-non-instance-p type1) + (classoid-is-or-inherits type1 'function)) + (values nil t)) + ((classoid-definitely-instancep type1) + (values t t)) + (t + (values nil nil)))) + ((and (eq type2 *funcallable-instance-type*) (classoid-p type1)) + (if (and (not (classoid-non-instance-p type1)) + (classoid-inherits-from type1 'function)) + (values t t) + (values nil t))) + (t + ;; FIXME: This seems to rely on there only being 4 or 5 + ;; NAMED-TYPE values, and the exclusion of various + ;; possibilities above. It would be good to explain it and/or + ;; rewrite it so that it's clearer. + (values nil t)))) + +(define-type-method (named :simple-intersection2) (type1 type2) + (cond + ((and (eq type1 *extended-sequence-type*) + (or (eq type2 *instance-type*) + (eq type2 *funcallable-instance-type*))) + nil) + ((and (or (eq type1 *instance-type*) + (eq type1 *funcallable-instance-type*)) + (eq type2 *extended-sequence-type*)) + nil) + (t + (hierarchical-intersection2 type1 type2)))) + +(define-type-method (named :complex-intersection2) (type1 type2) + ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13. + ;; Perhaps when bug 85 is fixed it can be reenabled. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. + (flet ((empty-unless-hairy (type) + (unless (or (type-might-contain-other-types-p type) + (member-type-p type)) + *empty-type*))) + (cond + ((eq type2 *extended-sequence-type*) + (typecase type1 + ((satisfies classoid-definitely-instancep) *empty-type*) ; dubious! + (classoid (cond + ((classoid-non-instance-p type1) *empty-type*) + ((classoid-inherits-from type1 'sequence) type1))) + (t (empty-unless-hairy type1)))) + ((eq type2 *instance-type*) + (typecase type1 + ((satisfies classoid-definitely-instancep) type1) + (classoid (when (or (classoid-non-instance-p type1) + (classoid-is-or-inherits type1 'function)) + *empty-type*)) + (t (empty-unless-hairy type1)))) + ((eq type2 *funcallable-instance-type*) + (typecase type1 + ((satisfies classoid-definitely-instancep) *empty-type*) + (classoid + (cond + ((classoid-non-instance-p type1) *empty-type*) + ((classoid-inherits-from type1 'function) type1) + ((type= type1 (find-classoid 'function)) type2))) + (fun-type nil) + (t (empty-unless-hairy type1)))) + (t (hierarchical-intersection2 type1 type2))))) + +(define-type-method (named :complex-union2) (type1 type2) + ;; Perhaps when bug 85 is fixed this can be reenabled. + ;;(aver (not (eq type2 *wild-type*))) ; * isn't really a type. + (cond + ((eq type2 *extended-sequence-type*) + (cond ((not (classoid-p type1)) nil) + ((and (not (classoid-non-instance-p type1)) + (classoid-inherits-from type1 'sequence)) + type2))) + ((eq type2 *instance-type*) + (when (and (classoid-p type1) + (neq type1 (specifier-type 'function)) + (not (classoid-non-instance-p type1)) + (not (classoid-inherits-from type1 'function))) + type2)) + ((eq type2 *funcallable-instance-type*) + (cond ((not (classoid-p type1)) nil) + ((classoid-non-instance-p type1) nil) + ((not (classoid-inherits-from type1 'function)) nil) + ((eq type1 (specifier-type 'function)) type1) + (t type2))) + (t (hierarchical-union2 type1 type2)))) + +(define-type-method (named :negate) (x) + (aver (not (eq x *wild-type*))) + (cond + ((eq x *universal-type*) *empty-type*) + ((eq x *empty-type*) *universal-type*) + ((or (eq x *instance-type*) + (eq x *funcallable-instance-type*) + (eq x *extended-sequence-type*)) + (make-negation-type x)) + (t (bug "NAMED type unexpected: ~S" x)))) + +(define-type-method (named :unparse) (x) + (named-type-name x)) + +;;;; hairy and unknown types + +;; ENUMERABLE-P is T because a hairy type could be equivalent to a MEMBER type. +;; e.g. any SATISFIES with a predicate returning T over a finite domain. +;; But in practice there's nothing that can be done with this information, +;; because we don't call random predicates when performing operations on types +;; as objects, only when checking for inclusion of something in the type. +(define-type-class hairy :enumerable t :might-contain-other-types t) + +;;; Without some special HAIRY cases, we massively pollute the type caches +;;; with objects that are all equivalent to *EMPTY-TYPE*. e.g. +;;; (AND (SATISFIES LEGAL-FUN-NAME-P) (SIMPLE-ARRAY CHARACTER (*))) and +;;; (AND (SATISFIES KEYWORDP) CONS). Since the compiler doesn't know +;;; that they're just *EMPTY-TYPE*, its keeps building more and more complex +;;; expressions involving them. I'm not sure why those two are so prevalent +;;; but they definitely seem to be. We can improve performance by reducing +;;; them to *EMPTY-TYPE* which means we need a way to recognize those hairy +;;; types in order reason about them. Interning them is how we recognize +;;; them, as they can be compared by EQ. +#+sb-xc-host +(progn + (defvar *satisfies-keywordp-type* + (!make-interned-hairy-type '(satisfies keywordp))) + (defvar *fun-name-type* + (!make-interned-hairy-type '(satisfies legal-fun-name-p)))) + +(define-type-method (hairy :negate) (x) (make-negation-type x)) + +(define-type-method (hairy :unparse) (x) + (hairy-type-specifier x)) + +(define-type-method (hairy :simple-subtypep) (type1 type2) + (let ((hairy-spec1 (hairy-type-specifier type1)) + (hairy-spec2 (hairy-type-specifier type2))) + (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) + (values t t)) + ((maybe-reparse-specifier! type1) + (csubtypep type1 type2)) + ((maybe-reparse-specifier! type2) + (csubtypep type1 type2)) + (t + (values nil nil))))) + +(define-type-method (hairy :complex-subtypep-arg2) (type1 type2) + (if (maybe-reparse-specifier! type2) + (csubtypep type1 type2) + (let ((specifier (hairy-type-specifier type2))) + (cond ((and (consp specifier) (eql (car specifier) 'satisfies)) + (case (cadr specifier) + ((keywordp) (if (type= type1 (specifier-type 'symbol)) + (values nil t) + (invoke-complex-subtypep-arg1-method type1 type2))) + (t (invoke-complex-subtypep-arg1-method type1 type2)))) + (t + (invoke-complex-subtypep-arg1-method type1 type2)))))) + +(define-type-method (hairy :complex-subtypep-arg1) (type1 type2) + (if (maybe-reparse-specifier! type1) + (csubtypep type1 type2) + (values nil nil))) + +(define-type-method (hairy :complex-=) (type1 type2) + (if (maybe-reparse-specifier! type2) + (type= type1 type2) + (values nil nil))) + +(define-type-method (hairy :simple-intersection2 :complex-intersection2) + (type1 type2) + (acond ((type= type1 type2) + type1) + ((eq type2 (literal-ctype *satisfies-keywordp-type*)) + ;; (AND (MEMBER A) (SATISFIES KEYWORDP)) is possibly non-empty + ;; if A is re-homed as :A. However as a special case that really + ;; does occur, (AND (MEMBER NIL) (SATISFIES KEYWORDP)) + ;; is empty because of the illegality of changing NIL's package. + (if (eq type1 (specifier-type 'null)) + *empty-type* + (multiple-value-bind (answer certain) + (types-equal-or-intersect type1 (specifier-type 'symbol)) + (and (not answer) certain *empty-type*)))) + ((eq type2 (literal-ctype *fun-name-type*)) + (multiple-value-bind (answer certain) + (types-equal-or-intersect type1 (specifier-type 'symbol)) + (and (not answer) + certain + (multiple-value-bind (answer certain) + (types-equal-or-intersect type1 (specifier-type 'cons)) + (and (not answer) certain *empty-type*))))) + ((and (typep (hairy-type-specifier type2) '(cons (eql satisfies))) + (info :function :predicate-truth-constraint + (cadr (hairy-type-specifier type2)))) + (multiple-value-bind (answer certain) + (types-equal-or-intersect type1 (specifier-type it)) + (and (not answer) certain *empty-type*))))) + +(define-type-method (hairy :simple-union2) + (type1 type2) + (if (type= type1 type2) + type1 + nil)) + +(define-type-method (hairy :simple-=) (type1 type2) + (if (equal-but-no-car-recursion (hairy-type-specifier type1) + (hairy-type-specifier type2)) + (values t t) + (values nil nil))) + +;;; This list exists so that we can turn builtin (SATISFIES fn) types into types +;;; amenable to algebra, because apparently there are some masochistic users +;;; who expect (SUBTYPEP 'COMPLEX '(AND NUMBER (SATISFIES REALP))) => NIL and T. +;;; There are possibly other entries that could go here, +;;; e.g. (SATISFIES ARRAY-HEADER-P) is something involving the AND, NOT, OR +;;; combinators. But it might render the expression too hairy to operate on. +(dolist (pair '((arrayp array) + (atom atom) + (bit-vector-p bit-vector) + (characterp character) + (compiled-function-p compiled-function) + (complexp complex) + (consp cons) + (floatp float) + (functionp function) + (hash-table-p hash-table) + (integerp integer) + ;; KEYWORD is (SATISFIES KEYWORDP), so we can't turn + ;; the predicate into KEYWORD + (listp list) + (numberp number) + (packagep package) + (pathnamep pathname) + (random-state-p random-state) + (rationalp rational) + (readtablep readtable) + (realp real) + (simple-bit-vector-p simple-bit-vector) + (simple-string-p simple-string) + (simple-vector-p simple-vector) + (streamp stream) + (stringp string) + (symbolp symbol) + (vectorp vector))) + (destructuring-bind (function type) pair + (setf (info :function :predicate-for function) type))) + +(def-type-translator satisfies :list (&whole whole predicate-name) + ;; "* may appear as the argument to a SATISFIES type specifier, but it + ;; indicates the literal symbol *" (which in practice is not useful) + (unless (symbolp predicate-name) + (error 'simple-type-error + :datum predicate-name + :expected-type 'symbol + :format-control "The SATISFIES predicate name is not a symbol: ~S" + :format-arguments (list predicate-name))) + (case predicate-name + (keywordp (literal-ctype *satisfies-keywordp-type*)) + (legal-fun-name-p (literal-ctype *fun-name-type*)) + (adjustable-array-p (specifier-type '(and array (not simple-array)))) + (t (let ((type (info :function :predicate-for predicate-name))) + (if type + (specifier-type type) + (%make-hairy-type whole)))))) + +;;;; negation types + +;; Former comment was: +;; FIXME: is this right? It's what they had before, anyway +;; But I think the reason it's right is that "enumerable :t" is equivalent +;; to "maybe" which is actually the conservative assumption, same as HAIRY. +(define-type-class negation :enumerable t :might-contain-other-types t) + +(define-type-method (negation :negate) (x) + (negation-type-type x)) + +(define-type-method (negation :unparse) (x) + (if (type= (negation-type-type x) (specifier-type 'cons)) + 'atom + `(not ,(type-specifier (negation-type-type x))))) + +(define-type-method (negation :simple-subtypep) (type1 type2) + (csubtypep (negation-type-type type2) (negation-type-type type1))) + +(define-type-method (negation :complex-subtypep-arg2) (type1 type2) + (let* ((complement-type2 (negation-type-type type2)) + (intersection2 (type-intersection2 type1 + complement-type2))) + (if intersection2 + ;; FIXME: if uncertain, maybe try arg1? + (type= intersection2 *empty-type*) + (invoke-complex-subtypep-arg1-method type1 type2)))) + +(define-type-method (negation :complex-subtypep-arg1) (type1 type2) + ;; "Incrementally extended heuristic algorithms tend inexorably toward the + ;; incomprehensible." -- http://www.unlambda.com/~james/lambda/lambda.txt + ;; + ;; You may not believe this. I couldn't either. But then I sat down + ;; and drew lots of Venn diagrams. Comments involving a and b refer + ;; to the call (subtypep '(not a) 'b) -- CSR, 2002-02-27. + (block nil + ;; (Several logical truths in this block are true as long as + ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a + ;; case with b=T where we actually reach this type method, but + ;; we'll test for and exclude this case anyway, since future + ;; maintenance might make it possible for it to end up in this + ;; code.) + (multiple-value-bind (equal certain) + (type= type2 *universal-type*) + (unless certain + (return (values nil nil))) + (when equal + (return (values t t)))) + (let ((complement-type1 (negation-type-type type1))) + ;; Do the special cases first, in order to give us a chance if + ;; subtype/supertype relationships are hairy. + (multiple-value-bind (equal certain) + (type= complement-type1 type2) + ;; If a = b, ~a is not a subtype of b (unless b=T, which was + ;; excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; KLUDGE: ANSI requires that the SUBTYPEP result between any + ;; two built-in atomic type specifiers never be uncertain. This + ;; is hard to do cleanly for the built-in types whose + ;; definitions include (NOT FOO), i.e. CONS and RATIO. However, + ;; we can do it with this hack, which uses our global knowledge + ;; that our implementation of the type system uses disjoint + ;; implementation types to represent disjoint sets (except when + ;; types are contained in other types). (This is a KLUDGE + ;; because it's fragile. Various changes in internal + ;; representation in the type system could make it start + ;; confidently returning incorrect results.) -- WHN 2002-03-08 + (unless (or (type-might-contain-other-types-p complement-type1) + (type-might-contain-other-types-p type2)) + ;; Because of the way our types which don't contain other + ;; types are disjoint subsets of the space of possible values, + ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B + ;; is not T, as checked above). + (return (values nil t))) + ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as + ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, + ;; and then the :SIMPLE-SUBTYPEP method would be used instead. + ;; But a CSUBTYPEP relationship might still hold: + (multiple-value-bind (equal certain) + (csubtypep complement-type1 type2) + ;; If a is a subtype of b, ~a is not a subtype of b (unless + ;; b=T, which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + (multiple-value-bind (equal certain) + (csubtypep type2 complement-type1) + ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: + ;; That's not true if a=T. Do we know at this point that a is + ;; not T?) + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? + ;; KLUDGE case above: Other cases here would rely on being able + ;; to catch all possible cases, which the fragility of this type + ;; system doesn't inspire me; for instance, if a is type= to ~b, + ;; then we want T, T; if this is not the case and the types are + ;; disjoint (have an intersection of *empty-type*) then we want + ;; NIL, T; else if the union of a and b is the *universal-type* + ;; then we want T, T. So currently we still claim to be unsure + ;; about e.g. (subtypep '(not fixnum) 'single-float). + ;; + ;; OTOH we might still get here: + (values nil nil)))) + +(define-type-method (negation :complex-=) (type1 type2) + ;; (NOT FOO) isn't equivalent to anything that's not a negation + ;; type, except possibly a type that might contain it in disguise. + (declare (ignore type2)) + (if (type-might-contain-other-types-p type1) + (values nil nil) + (values nil t))) + +(define-type-method (negation :simple-intersection2) (type1 type2) + (let ((not1 (negation-type-type type1)) + (not2 (negation-type-type type2))) + (cond + ((csubtypep not1 not2) type2) + ((csubtypep not2 not1) type1) + ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2 + ;; method, below? The clause would read + ;; + ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*) + ;; + ;; but with proper canonicalization of negation types, there's + ;; no way of constructing two negation types with union of their + ;; negations being the universal type. + (t + (aver (not (eq (type-union not1 not2) *universal-type*))) + nil)))) + +(defun maybe-complex-array-refinement (type1 type2) + ;; a :MAYBE complex array intersected with (NOT ) + ;; where is the same in all aspects as except that + ;; its complexp value is in {T,NIL} should return altered + ;; with its COMPLEXP being the negation of the value from . + ;; As a particular case which is no longer special in handling it, + ;; the righthand side could be TYPE= to (NOT SIMPLE-ARRAY) + ;; which will match any lefthand side and do what it always did. + (let* ((ntype (negation-type-type type2)) + (ndims (array-type-dimensions ntype)) + (ncomplexp (array-type-complexp ntype)) + (nseltype (array-type-specialized-element-type ntype)) + (neltype (array-type-element-type ntype))) + (when (and (eq (array-type-complexp type1) :maybe) + (neq ncomplexp :maybe) + (or (eql ndims '*) + (equal (array-type-dimensions type1) ndims)) + (or (eq nseltype *wild-type*) + (eq (array-type-specialized-element-type type1) nseltype)) + (or (eq neltype *wild-type*) + (type= (array-type-element-type type1) neltype))) + (make-array-type (array-type-dimensions type1) + :complexp (not (array-type-complexp ntype)) + :specialized-element-type (array-type-specialized-element-type type1) + :element-type (array-type-element-type type1))))) + +(define-type-method (negation :complex-intersection2) (type1 type2) + (cond + ((csubtypep type1 (negation-type-type type2)) *empty-type*) + ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) + type1) + ((and (array-type-p type1) (array-type-p (negation-type-type type2))) + (maybe-complex-array-refinement type1 type2)) + (t nil))) + +(define-type-method (negation :simple-union2) (type1 type2) + (let ((not1 (negation-type-type type1)) + (not2 (negation-type-type type2))) + (cond + ((csubtypep not1 not2) type1) + ((csubtypep not2 not1) type2) + ((eq (type-intersection not1 not2) *empty-type*) + *universal-type*) + (t nil)))) + +(define-type-method (negation :complex-union2) (type1 type2) + (cond + ((csubtypep (negation-type-type type2) type1) *universal-type*) + ((eq (type-intersection type1 (negation-type-type type2)) *empty-type*) + type2) + (t nil))) + +(define-type-method (negation :simple-=) (type1 type2) + (type= (negation-type-type type1) (negation-type-type type2))) + +(def-type-translator not :list ((:context context) typespec) + ;; "* is not permitted as an argument to the NOT type specifier." + (type-negation (specifier-type typespec context 'not))) + +;;;; numeric types + +(declaim (inline numeric-type-equal)) +(defun numeric-type-equal (type1 type2) + ;; TODO: these 3 can be packed into an integer which makes for just 1 comparison. + ;; (Maybe if 64-bit words use the %BITS slot which has plenty of unused bits) + (and (eq (numeric-type-class type1) (numeric-type-class type2)) + (eq (numeric-type-format type1) (numeric-type-format type2)) + (eq (numeric-type-complexp type1) (numeric-type-complexp type2)))) + +(define-type-class number :enumerable #'numeric-type-enumerable :might-contain-other-types nil) + +(define-type-method (number :simple-=) (type1 type2) + ;; TODO: construct the hash bits for NUMBER types using a deterministic hash of + ;; the low + high bounds. Then TYPE= can be true only if the hashes are =. + (values + (and (numeric-type-equal type1 type2) + (equalp (numeric-type-low type1) (numeric-type-low type2)) + (equalp (numeric-type-high type1) (numeric-type-high type2))) + t)) + +(declaim (inline bounds-unbounded-p)) +(defun bounds-unbounded-p (low high) + (and (null low) (eq high low))) + +(define-type-method (number :negate) (type) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (if (bounds-unbounded-p low high) + (make-negation-type type) + (type-union + (make-negation-type (modified-numeric-type type :low nil :high nil)) + (cond + ((null low) + (modified-numeric-type + type + :low (if (consp high) (car high) (list high)) + :high nil)) + ((null high) + (modified-numeric-type + type + :low nil + :high (if (consp low) (car low) (list low)))) + (t (type-union + (modified-numeric-type + type + :low nil + :high (if (consp low) (car low) (list low))) + (modified-numeric-type + type + :low (if (consp high) (car high) (list high)) + :high nil)))))))) + +(define-type-method (number :unparse) (type) + (let* ((complexp (numeric-type-complexp type)) + (low (numeric-type-low type)) + (high (numeric-type-high type)) + (base (case (numeric-type-class type) + (integer 'integer) + (rational 'rational) + (float (or (numeric-type-format type) 'float)) + (t 'real)))) + (let ((base+bounds + (cond ((and (eq base 'integer) high low) + (let ((high-count (logcount high)) + (high-length (integer-length high))) + (cond ((= low 0) + (cond ((= high 0) '(integer 0 0)) + ((= high 1) 'bit) + ((and (= high-count high-length) + (plusp high-length)) + `(unsigned-byte ,high-length)) + (t + `(mod ,(1+ high))))) + ((and (= low most-negative-fixnum) + (= high most-positive-fixnum)) + 'fixnum) + ((and (= low (lognot high)) + (= high-count high-length) + (> high-count 0)) + `(signed-byte ,(1+ high-length))) + (t + `(integer ,low ,high))))) + (high `(,base ,(or low '*) ,high)) + (low + (if (and (eq base 'integer) (= low 0)) + 'unsigned-byte + `(,base ,low))) + (t base)))) + (ecase complexp + (:real + (aver (neq base 'real)) + base+bounds) + (:complex + (aver (neq base 'real)) + `(complex ,base+bounds)) + ((nil) + (aver (eq base+bounds 'real)) + 'number))))) + +(define-type-method (number :singleton-p) (type) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (if (and low + (eql low high) + (eql (numeric-type-complexp type) :real) + (if (eq (numeric-type-class type) 'float) + ;; (float 0.0 0.0) fits both -0.0 and 0.0 + (not (zerop low)) + (member (numeric-type-class type) '(integer rational)))) + (values t low) + (values nil nil)))) + +(defun interned-numeric-type (specifier &rest args) + (apply '%make-numeric-type + :%bits (pack-interned-ctype-bits + 'number nil + (when specifier (sb-vm::saetp-index-or-lose specifier))) + args)) + +#+sb-xc-host +(progn + ;; Work around an ABCL bug. This fails to load: + ;; (macrolet ((foo-it (x) `(- ,x))) (defvar *var* (foo-it 3))) + (defvar *interned-signed-byte-types*) + (defvar *interned-unsigned-byte-types*) + (macrolet ((int-type (low high) + `(interned-numeric-type (when (sb-c::find-saetp spec) spec) + :class 'integer :enumerable t + :low ,low :high ,high))) + (setq *interned-signed-byte-types* + (do ((v (make-array sb-vm:n-word-bits)) + (i 1 (1+ i)) + (j -1)) + ((> i sb-vm:n-word-bits) v) + (let ((spec (if (= i sb-vm:n-fixnum-bits) + 'fixnum + `(signed-byte ,i)))) + (setf (svref v (1- i)) (int-type j (lognot j)) + j (ash j 1))))) + (setq *interned-unsigned-byte-types* + (let ((v (make-array (1+ sb-vm:n-word-bits)))) + (dotimes (i (length v) v) + (let ((spec (if (= i 1) 'bit `(unsigned-byte ,i)))) + (setf (svref v i) (int-type 0 (1- (ash 1 i)))))))))) + +;;; Coerce a numeric type bound to the given type while handling +;;; exclusive bounds. +(defun coerce-numeric-bound (bound type) + (flet ((c (thing) + (case type + (rational (rational thing)) + ((float single-float) + (cond #-sb-xc-host + ((<= most-negative-single-float thing most-positive-single-float) + (coerce thing 'single-float)) + (t + (return-from coerce-numeric-bound)))) + (double-float + (cond #-sb-xc-host + ((<= most-negative-double-float thing most-positive-double-float) + (coerce thing 'double-float)) + (t + (return-from coerce-numeric-bound))))))) + (when bound + (if (consp bound) + (list (c (car bound))) + (c bound))))) + +;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some +;;; cases, despite the name, we return *EMPTY-TYPE* or a UNION-TYPE instead of a +;;; NUMERIC-TYPE. +;;; +;;; FIXME: The ENUMERABLE flag is unexpectedly NIL for types that +;;; come from parsing MEMBER. But bounded integer ranges, +;;; however large, are enumerable: +;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(SIGNED-BYTE 99))) => T +;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(COMPLEX (SIGNED-BYTE 99)))) => T +;;; but, in contrast, +;;; (TYPE-ENUMERABLE (SPECIFIER-TYPE '(EQL 5))) => NIL. +;;; I can't figure out whether this is supposed to matter. +;;; Moreover, it seems like this function should be responsible +;;; for figuring out the right value so that callers don't have to. +(defun make-numeric-type (&key class format (complexp :real) low high + enumerable) + (declare (type (member integer rational float nil) class)) + (macrolet ((unionize (types classes formats) + `(let (types) + (loop for thing in ',types + for class in ',classes + for format in ',formats + do + (let ((low (coerce-numeric-bound low thing)) + (high (coerce-numeric-bound high thing))) + (push (make-numeric-type + :format format + :class class + :complexp complexp + :low low + :high high + :enumerable enumerable) + types))) + (apply #'type-union types)))) + (when (and (null class) (member complexp '(:real :complex))) + (return-from make-numeric-type + (if (bounds-unbounded-p low high) + (if (eq complexp :complex) + (specifier-type 'complex) + (specifier-type 'real)) + (unionize (rational single-float double-float) + (rational float float) + (nil single-float double-float))))) + (when (and (eql class 'float) (member complexp '(:complex :real)) (eql format nil)) + (return-from make-numeric-type + (if (bounds-unbounded-p low high) + (if (eq complexp :complex) + (specifier-type '(complex float)) + (specifier-type 'float)) + (unionize (single-float double-float #+long-float (error "long-float")) + (float float) + (single-float double-float))))) + (when (and (null complexp) + (or class format low high)) + (return-from make-numeric-type + (type-union (make-numeric-type :class class :format format + :low low :high high :enumerable enumerable + :complexp :complex) + (make-numeric-type :class class :format format + :low low :high high :enumerable enumerable + :complexp :real))))) + (multiple-value-bind (low high) + (case class + (integer + ;; INTEGER types always have their LOW and HIGH bounds + ;; represented as inclusive, not exclusive values. + (values (if (consp low) (1+ (type-bound-number low)) low) + (if (consp high) (1- (type-bound-number high)) high))) + (t + ;; no canonicalization necessary + (values low high))) + ;; if interval is empty + (when (and low high + (if (or (consp low) (consp high)) ; if either bound is exclusive + (sb-xc:>= (type-bound-number low) (type-bound-number high)) + (sb-xc:> low high))) + (return-from make-numeric-type *empty-type*)) + (when (and (eq class 'rational) (integerp low) (eql low high)) + (setf class 'integer)) + ;; Either lookup the canonical interned object for + ;; a point in the type lattice, or construct a new one. + (or (case class + (float + (macrolet ((float-type (fmt complexp + &aux (spec (if (eq complexp :complex) + `(complex ,fmt) fmt))) + `(literal-ctype (interned-numeric-type ',spec + :class 'float :complexp ,complexp + :format ',fmt :enumerable nil) + ,spec))) + (when (bounds-unbounded-p low high) + (ecase format + (single-float + (case complexp + (:real (float-type single-float :real)) + (:complex (float-type single-float :complex)))) + (double-float + (case complexp + (:real (float-type double-float :real)) + (:complex (float-type double-float :complex)))))))) + (integer + (macrolet ((int-type (low high) + `(literal-ctype + (interned-numeric-type nil + :class 'integer :low ,low :high ,high + :enumerable (if (and ,low ,high) t nil)) + (integer ,(or low '*) ,(or high '*))))) + (cond ((neq complexp :real) nil) + ((and (eql low 0) (eql high (1- array-dimension-limit))) + (int-type 0 #.(1- array-dimension-limit))) ; INDEX type + ((null high) + (cond ((not low) (int-type nil nil)) + ((eql low 0) (int-type 0 nil)) + ((eql low (1+ most-positive-fixnum)) + ;; positive bignum + (int-type #.(1+ most-positive-fixnum) nil)))) + ((or (eql high most-positive-word) + ;; is (1+ high) a power-of-2 ? + (and (typep high 'word) (zerop (logand (1+ high) high)))) + (cond ((eql low 0) + (svref (literal-ctype-vector *interned-unsigned-byte-types*) + (integer-length (truly-the word high)))) + ((and (< high most-positive-word) (eql low (lognot high))) + (svref (literal-ctype-vector *interned-signed-byte-types*) + (integer-length (truly-the word high)))))) + ((and (not low) (eql high (1- most-negative-fixnum))) + ;; negative bignum + (int-type nil #.(1- most-negative-fixnum)))))) + (rational + (cond ((and (eq complexp :real) (bounds-unbounded-p low high)) + (literal-ctype (interned-numeric-type nil :class 'rational) + rational)) + ((and (eq complexp :complex) (bounds-unbounded-p low high)) + (literal-ctype (interned-numeric-type nil :complexp :complex + :class 'rational) + (complex rational))))) + ((nil) + (and (not format) + (not complexp) + (bounds-unbounded-p low high) + (literal-ctype (interned-numeric-type nil :complexp nil) number)))) + (%make-numeric-type :class class :format format :complexp complexp + :low low :high high :enumerable enumerable)))) + +(defun modified-numeric-type (base + &key + (class (numeric-type-class base)) + (format (numeric-type-format base)) + (complexp (numeric-type-complexp base)) + (low (numeric-type-low base)) + (high (numeric-type-high base)) + (enumerable (type-enumerable base))) + (make-numeric-type :class class + :format format + :complexp complexp + :low low + :high high + :enumerable enumerable)) + +;;; Return true if X is "less than or equal" to Y, taking open bounds +;;; into consideration. CLOSED is the predicate used to test the bound +;;; on a closed interval (e.g. <=), and OPEN is the predicate used on +;;; open bounds (e.g. <). Y is considered to be the outside bound, in +;;; the sense that if it is infinite (NIL), then the test succeeds, +;;; whereas if X is infinite, then the test fails (unless Y is also +;;; infinite). +;;; +;;; This is for comparing bounds of the same kind, e.g. upper and +;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds. +(defmacro numeric-bound-test (x y closed open) + (setq closed (intern (string closed) "SB-XC") + open (intern (string open) "SB-XC")) + `(cond ((not ,y) t) + ((not ,x) nil) + ((consp ,x) + (if (consp ,y) + (,closed (car ,x) (car ,y)) + (,closed (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) + +;;; This is used to compare upper and lower bounds. This is different +;;; from the same-bound case: +;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we +;;; return true if *either* arg is NIL. +;;; -- an open inner bound is "greater" and also squeezes the interval, +;;; causing us to use the OPEN test for those cases as well. +(defmacro numeric-bound-test* (x y closed open) + (setq closed (intern (string closed) "SB-XC") + open (intern (string open) "SB-XC")) + `(cond ((not ,y) t) + ((not ,x) t) + ((consp ,x) + (if (consp ,y) + (,open (car ,x) (car ,y)) + (,open (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) + +;;; Return whichever of the numeric bounds X and Y is "maximal" +;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >). +;;; This is only meaningful for maximizing like bounds, i.e. upper and +;;; upper. If MAX-P is true, then we return NIL if X or Y is NIL, +;;; otherwise we return the other arg. +(defmacro numeric-bound-max (x y closed open max-p) + (setq closed (intern (string closed) "SB-XC") + open (intern (string open) "SB-XC")) + (once-only ((n-x x) + (n-y y)) + `(cond ((not ,n-x) ,(if max-p nil n-y)) + ((not ,n-y) ,(if max-p nil n-x)) + ((consp ,n-x) + (if (consp ,n-y) + (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) + (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) + (t + (if (consp ,n-y) + (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) + (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) + +(define-type-method (number :simple-subtypep) (type1 type2) + (let ((class1 (numeric-type-class type1)) + (class2 (numeric-type-class type2)) + (complexp2 (numeric-type-complexp type2)) + (format2 (numeric-type-format type2)) + (low1 (numeric-type-low type1)) + (high1 (numeric-type-high type1)) + (low2 (numeric-type-low type2)) + (high2 (numeric-type-high type2))) + ;; If one is complex and the other isn't, they are disjoint. + (cond ((not (or (eq (numeric-type-complexp type1) complexp2) + (null complexp2))) + (values nil t)) + ;; If the classes are specified and different, the types are + ;; disjoint unless type2 is RATIONAL and type1 is INTEGER. + ;; [ or type1 is INTEGER and type2 is of the form (RATIONAL + ;; X X) for integral X, but this is dealt with in the + ;; canonicalization inside MAKE-NUMERIC-TYPE ] + ((not (or (eq class1 class2) + (null class2) + (and (eq class1 'integer) (eq class2 'rational)))) + (values nil t)) + ;; If the float formats are specified and different, the types + ;; are disjoint. + ((not (or (eq (numeric-type-format type1) format2) + (null format2))) + (values nil t)) + ;; Check the bounds. + ((and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test high1 high2 <= <)) + (values t t)) + (t + (values nil t))))) + +(!define-superclasses number ((number)) !cold-init-forms) + +;;; If the high bound of LOW is adjacent to the low bound of HIGH, +;;; then return true, otherwise NIL. Adjacency of floating-point intervals +;;; implies that exactly one is an open interval and exactly one is closed +;;; at the adjacency point. +;;; We never (as of now) get here in the cross-compiler with target +;;; floating-point numbers. This seems legitimate as we seldom specify +;;; anything as open intervals. The few cases seem to be the fun-types +;;; of %RANDOM-{SINGLE,DOUBLE}-FLOAT and HASH-TABLE-REHASH-mumble. +(defun numeric-types-adjacent (low high) + (let ((low-bound (numeric-type-high low)) + (high-bound (numeric-type-low high))) + ;; Return T if and only if X is EQL to Y, or X = 0 and -X is EQL to Y. + ;; If both intervals have the same sign of zero at the adjacency point, + ;; then they intersect (as per NUMERIC-TYPES-INTESECT) + ;; so it doesn't matter much what we say here. + (flet ((float-zeros-eqlish (x y) + (or (eql x y) + ;; Calling (EQL (- X) Y) might cons. Using = would be almost the same + ;; but not cons, however I prefer not to assume that the caller has + ;; already checked for matching float formats. EQL enforces that. + ;; Change to use SB-XC:- here if anything requires it. + (and (fp-zero-p x) (fp-zero-p y) (eql (- x) y))))) + (cond ((not (and low-bound high-bound)) nil) + ((and (consp low-bound) (consp high-bound)) nil) + ((consp low-bound) (float-zeros-eqlish (car low-bound) high-bound)) + ((consp high-bound) (float-zeros-eqlish low-bound (car high-bound))) + ((and (eq (numeric-type-class low) 'integer) + (eq (numeric-type-class high) 'integer)) + (eql (1+ low-bound) high-bound)) ; Integer intervals are never open + (t + nil))))) + +;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. +;;; +;;; Binding *APPROXIMATE-NUMERIC-UNIONS* to T allows merging non-adjacent +;;; numeric types, eg (OR (INTEGER 0 12) (INTEGER 20 128)) => (INTEGER 0 128), +;;; the compiler does this occasionally during type-derivation to avoid +;;; creating absurdly complex unions of numeric types. +(defvar *approximate-numeric-unions* nil) + +(defun rational-integer-union (rational integer) + (let ((formatr (numeric-type-format rational)) + (formati (numeric-type-format integer)) + (complexpr (numeric-type-complexp rational)) + (complexpi (numeric-type-complexp integer)) + (lowi (numeric-type-low integer)) + (highi (numeric-type-high integer)) + (lowr (numeric-type-low rational)) + (highr (numeric-type-high rational))) + (when (and (eq formatr formati) (eq complexpr complexpi)) + (cond + ;; handle the special-case that a single integer expands the + ;; rational interval. + ((and (integerp lowi) (integerp highi) (= lowi highi) + (or *approximate-numeric-unions* + (numeric-types-adjacent integer rational) + (numeric-types-adjacent rational integer))) + (make-numeric-type + :class 'rational :format formatr :complexp complexpr + :low (numeric-bound-max lowr lowi <= < t) + :high (numeric-bound-max highr highi >= > t))) + ;; the general case: + ;; + ;; 1. expand the integer type by those integers contained by + ;; the rational type, if possible. + ;; + ;; 2. turn open bounds in the rational contained in the + ;; integer type into closed ones. + ;; + ;; (if neither of these applies, return NIL) + (t + (let* ((integers-of-rational + (make-numeric-type + :class 'integer :format formatr :complexp complexpr + :low (round-numeric-bound lowr 'integer formatr t) + :high (round-numeric-bound highr 'integer formatr nil))) + (new-integer + (and (numeric-type-p integers-of-rational) + (or *approximate-numeric-unions* + (numeric-types-intersect integers-of-rational integer) + (numeric-types-adjacent integers-of-rational integer) + (numeric-types-adjacent integer integers-of-rational)) + (let ((new-lowi (numeric-bound-max + lowi + (numeric-type-low integers-of-rational) + <= < t)) + (new-highi (numeric-bound-max + highi + (numeric-type-high integers-of-rational) + >= > t))) + (and (or (not (eql new-lowi lowi)) + (not (eql new-highi highi))) + (make-numeric-type + :class 'integer :format formatr :complexp complexpr + :low new-lowi :high new-highi))))) + (new-lowr + (and (consp lowr) + (integerp (car lowr)) + (let ((low-integer + (make-numeric-type + :class 'integer :format formati :complexp complexpi + :low (car lowr) :high (car lowr)))) + (and (numeric-types-intersect integer low-integer) + (numeric-type-low low-integer))))) + (new-highr + (and (consp highr) (integerp (car highr)) + (let ((high-integer + (make-numeric-type + :class 'integer :format formati :complexp complexpi + :low (car highr) :high (car highr)))) + (and (numeric-types-intersect integer high-integer) + (numeric-type-high high-integer))))) + (new-rational + (and (or new-lowr new-highr) + (make-numeric-type + :class 'rational :format formatr :complexp complexpr + :low (or new-lowr lowr) :high (or new-highr highr))))) + (cond + ((or new-integer new-rational) + (make-union-type nil (list (or new-integer integer) (or new-rational rational)))) + (t nil)))))))) + +(define-type-method (number :simple-union2) (type1 type2) + (declare (type numeric-type type1 type2)) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t + (let ((class1 (numeric-type-class type1)) + (format1 (numeric-type-format type1)) + (complexp1 (numeric-type-complexp type1)) + (class2 (numeric-type-class type2)) + (format2 (numeric-type-format type2)) + (complexp2 (numeric-type-complexp type2))) + (cond + ((and (eq class1 class2) + (eq format1 format2) + (eq complexp1 complexp2) + (or *approximate-numeric-unions* + (numeric-types-intersect type1 type2) + (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-type + :class class1 + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-type-low type1) + (numeric-type-low type2) + <= < t) + :high (numeric-bound-max (numeric-type-high type1) + (numeric-type-high type2) + >= > t))) + + ((and (eq class1 'rational) (eq class2 'integer)) + (rational-integer-union type1 type2)) + ((and (eq class1 'integer) (eq class2 'rational)) + (rational-integer-union type2 type1)) + (t nil)))))) + + +(!cold-init-forms ;; is !PRECOMPUTE-TYPES not doing the right thing? + (setf (info :type :kind 'number) :primitive) + (setf (info :type :builtin 'number) + (make-numeric-type :complexp nil))) + +(def-type-translator complex ((:context context) &optional (typespec '*)) + (if (eq typespec '*) + (specifier-type '(complex real)) + (labels ((not-numeric () + (error "The component type for COMPLEX is not numeric: ~S" + typespec)) + (not-real () + (error "The component type for COMPLEX is not a subtype of REAL: ~S" + typespec)) + (complex1 (component-type) + (unless (numeric-type-p component-type) + (not-numeric)) + (unless (eq (numeric-type-complexp component-type) :real) + (not-real)) + (if (csubtypep component-type (specifier-type '(eql 0))) + *empty-type* + (modified-numeric-type component-type + :complexp :complex))) + (do-complex (ctype) + (cond + ((eq ctype *empty-type*) *empty-type*) + ((eq ctype *universal-type*) (not-real)) + ((typep ctype 'numeric-type) (complex1 ctype)) + ((typep ctype 'union-type) + (%type-union (mapcar #'do-complex (union-type-types ctype)))) + ((typep ctype 'member-type) + (%type-union + (mapcar-member-type-members + (lambda (x) + (if (realp x) + (do-complex (ctype-of x)) + (not-real))) + ctype))) + ((and (typep ctype 'intersection-type) + ;; FIXME: This is very much a + ;; not-quite-worst-effort, but we are required to do + ;; something here because of our representation of + ;; RATIO as (AND RATIONAL (NOT INTEGER)): we must + ;; allow users to ask about (COMPLEX RATIO). This + ;; will of course fail to work right on such types + ;; as (AND INTEGER (SATISFIES ZEROP))... + (let ((numbers (remove-if-not + #'numeric-type-p + (intersection-type-types ctype)))) + (and (car numbers) + (null (cdr numbers)) + (eq (numeric-type-complexp (car numbers)) :real) + (complex1 (car numbers)))))) + (t + (multiple-value-bind (subtypep certainly) + (csubtypep ctype (specifier-type 'real)) + (if (and (not subtypep) certainly) + (not-real) + ;; ANSI just says that TYPESPEC is any subtype of + ;; type REAL, not necessarily a NUMERIC-TYPE. In + ;; particular, at this point TYPESPEC could legally + ;; be a hairy type like (AND NUMBER (SATISFIES + ;; REALP) (SATISFIES ZEROP)), in which case we fall + ;; through the logic above and end up here, + ;; stumped. + ;; FIXME: (COMPLEX NUMBER) is not rejected but should + ;; be, as NUMBER is clearly not a subtype of real. + (bug "~@<(known bug #145): The type ~S is too hairy to be ~ +used for a COMPLEX component.~:@>" + typespec))))))) + (let ((ctype (specifier-type typespec context))) + (do-complex ctype))))) + +;;; If X is *, return NIL, otherwise return the bound, which must be a +;;; member of TYPE or a one-element list of a member of TYPE. +;;; This is not necessarily the canonical bound. An integer bound +;;; should always be an atom, which we'll enforce later if needed. +(defmacro valid-bound (bound type) + `(cond ((eq ,bound '*) nil) + ((sb-xc:typep (if (singleton-p ,bound) (car ,bound) ,bound) ',type) ,bound) + (t + (error ,(format nil "~A bound is not * or ~A ~A or list of one ~:*~A: ~~S" + (string-capitalize bound) + (if (eq type 'integer) "an" "a") + (string-downcase type)) + ,bound)))) + +(def-type-translator integer (&optional (low '*) (high '*)) + (let ((lb (valid-bound low integer)) + (hb (valid-bound high integer))) + (make-numeric-type :class 'integer :complexp :real + :enumerable (not (null (and lb hb))) + :low lb :high hb))) + +(defmacro !def-bounded-type (type class format) + `(def-type-translator ,type (&optional (low '*) (high '*)) + (let ((lb (valid-bound low ,type)) + (hb (valid-bound high ,type))) + (make-numeric-type :class ',class :format ',format + :low lb :high hb)))) + +(!def-bounded-type rational rational nil) + +;;; Unlike CMU CL, we represent the types FLOAT and REAL as +;;; UNION-TYPEs of more primitive types, in order to make +;;; type representation more unique, avoiding problems in the +;;; simplification of things like +;;; (subtypep '(or (single-float -1.0 1.0) (single-float 0.1)) +;;; '(or (real -1 7) (single-float 0.1) (single-float -1.0 1.0))) +;;; When we allowed REAL to remain as a separate NUMERIC-TYPE, +;;; it was too easy for the first argument to be simplified to +;;; '(SINGLE-FLOAT -1.0), and for the second argument to be simplified +;;; to '(OR (REAL -1 7) (SINGLE-FLOAT 0.1)) and then for the +;;; SUBTYPEP to fail (returning NIL,T instead of T,T) because +;;; the first argument can't be seen to be a subtype of any of the +;;; terms in the second argument. +;;; +;;; The old CMU CL way was: +;;; (!def-bounded-type float float nil) +;;; (!def-bounded-type real nil nil) +;;; +;;; FIXME: If this new way works for a while with no weird new +;;; problems, we can go back and rip out support for separate FLOAT +;;; and REAL flavors of NUMERIC-TYPE. The new way was added in +;;; sbcl-0.6.11.22, 2001-03-21. +(defun coerce-bound (bound type upperp inner-coerce-bound-fun) + (declare (type function inner-coerce-bound-fun)) + (if (eq bound '*) + bound + (funcall inner-coerce-bound-fun bound type upperp))) + +(macrolet ((make-bound (val) + `(let ((coerced ,val)) + (if (listp bound) (list coerced) coerced)))) + +(defun inner-coerce-real-bound (bound type upperp) + (let ((nl most-negative-long-float) + (pl most-positive-long-float)) + (let ((nbound (if (listp bound) (car bound) bound))) + (ecase type + (rational + (make-bound (rational nbound))) + (float + (cond + ((floatp nbound) bound) + (t + ;; Coerce to the widest float format available, to avoid + ;; unnecessary loss of precision, but don't coerce + ;; unrepresentable numbers. + (ecase upperp + ((nil) + (when (sb-xc:< nbound nl) (return-from inner-coerce-real-bound nl))) + ((t) + (when (sb-xc:> nbound pl) (return-from inner-coerce-real-bound pl)))) + (make-bound (coerce nbound 'long-float))))))))) + +(defun inner-coerce-float-bound (bound type upperp) + (let ((nd most-negative-double-float) + (pd most-positive-double-float) + (ns most-negative-single-float) + (ps most-positive-single-float)) + (let ((nbound (if (listp bound) (car bound) bound))) + (ecase type + (single-float + (cond + ((cl:typep nbound 'single-float) bound) + (t + (ecase upperp + ((nil) + (when (sb-xc:< nbound ns) (return-from inner-coerce-float-bound ns))) + ((t) + (when (sb-xc:> nbound ps) (return-from inner-coerce-float-bound ps)))) + (make-bound (coerce nbound 'single-float))))) + (double-float + (cond + ((cl:typep nbound 'double-float) bound) + (t + (ecase upperp + ((nil) + (when (sb-xc:< nbound nd) (return-from inner-coerce-float-bound nd))) + ((t) + (when (sb-xc:> nbound pd) (return-from inner-coerce-float-bound pd)))) + (make-bound (coerce nbound 'double-float))))))))) +) ; end MACROLET + +(defun coerced-real-bound (bound type upperp) + (coerce-bound bound type upperp #'inner-coerce-real-bound)) +(defun coerced-float-bound (bound type upperp) + (coerce-bound bound type upperp #'inner-coerce-float-bound)) +(def-type-translator real (&optional (low '*) (high '*)) + (specifier-type `(or (float ,(coerced-real-bound low 'float nil) + ,(coerced-real-bound high 'float t)) + (rational ,(coerced-real-bound low 'rational nil) + ,(coerced-real-bound high 'rational t))))) +(def-type-translator float (&optional (low '*) (high '*)) + (specifier-type + `(or (single-float ,(coerced-float-bound low 'single-float nil) + ,(coerced-float-bound high 'single-float t)) + (double-float ,(coerced-float-bound low 'double-float nil) + ,(coerced-float-bound high 'double-float t)) + #+long-float ,(error "stub: no long float support yet")))) + +(macrolet ((define-float-format (f) `(!def-bounded-type ,f float ,f))) + (define-float-format single-float) + (define-float-format double-float)) + +(defun numeric-types-intersect (type1 type2) + (declare (type numeric-type type1 type2)) + (let* ((class1 (numeric-type-class type1)) + (class2 (numeric-type-class type2)) + (complexp1 (numeric-type-complexp type1)) + (complexp2 (numeric-type-complexp type2)) + (format1 (numeric-type-format type1)) + (format2 (numeric-type-format type2)) + (low1 (numeric-type-low type1)) + (high1 (numeric-type-high type1)) + (low2 (numeric-type-low type2)) + (high2 (numeric-type-high type2))) + ;; If one is complex and the other isn't, then they are disjoint. + (cond ((not (or (eq complexp1 complexp2) + (null complexp1) (null complexp2))) + nil) + ;; If either type is a float, then the other must either be + ;; specified to be a float or unspecified. Otherwise, they + ;; are disjoint. + ((and (eq class1 'float) + (not (member class2 '(float nil)))) nil) + ((and (eq class2 'float) + (not (member class1 '(float nil)))) nil) + ;; If the float formats are specified and different, the + ;; types are disjoint. + ((not (or (eq format1 format2) (null format1) (null format2))) + nil) + (t + ;; Check the bounds. This is a bit odd because we must + ;; always have the outer bound of the interval as the + ;; second arg. + (if (numeric-bound-test high1 high2 <= <) + (or (and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test* low1 high2 <= <)) + (and (numeric-bound-test low2 low1 >= >) + (numeric-bound-test* low2 high1 <= <))) + (or (and (numeric-bound-test* low2 high1 <= <) + (numeric-bound-test low2 low1 >= >)) + (and (numeric-bound-test high2 high1 <= <) + (numeric-bound-test* high2 low1 >= >)))))))) + +;;; Take the numeric bound X and convert it into something that can be +;;; used as a bound in a numeric type with the specified CLASS and +;;; FORMAT. If UP-P is true, then we round up as needed, otherwise we +;;; round down. UP-P true implies that X is a lower bound, i.e. (N) > N. +;;; +;;; This is used by NUMERIC-TYPE-INTERSECTION to mash the bound into +;;; the appropriate type number. X may only be a float when CLASS is +;;; FLOAT. +;;; +;;; ### Note: it is possible for the coercion to a float to overflow +;;; or underflow. This happens when the bound doesn't fit in the +;;; specified format. In this case, we should really return the +;;; appropriate {Most | Least}-{Positive | Negative}-XXX-Float float +;;; of desired format. But these conditions aren't currently signalled +;;; in any useful way. +;;; +;;; Also, when converting an open rational bound into a float we +;;; should probably convert it to a closed bound of the closest float +;;; in the specified format. KLUDGE: In general, open float bounds are +;;; screwed up. -- (comment from original CMU CL) +(defun round-numeric-bound (x class format up-p) + (if x + (let ((cx (if (consp x) (car x) x))) + (ecase class + ((nil rational) x) + (integer + (if (and (consp x) (integerp cx)) + (if up-p (1+ cx) (1- cx)) + (if up-p (ceiling cx) (floor cx)))) + (float + (aver format) + (let ((res + (cond + ((and format (subtypep format 'double-float)) + (if (sb-xc:<= most-negative-double-float cx most-positive-double-float) + (coerce cx format) + nil)) + (t + (if (sb-xc:<= most-negative-single-float cx most-positive-single-float) + ;; FIXME: bug #389 + (coerce cx (or format 'single-float)) + nil))))) + (if (and (consp x) res) + (list res) + res))))) + nil)) + +;;; Handle the case of type intersection on two numeric types. We use +;;; TYPES-EQUAL-OR-INTERSECT to throw out the case of types with no +;;; intersection. If an attribute in TYPE1 is unspecified, then we use +;;; TYPE2's attribute, which must be at least as restrictive. If the +;;; types intersect, then the only attributes that can be specified +;;; and different are the class and the bounds. +;;; +;;; When the class differs, we use the more restrictive class. The +;;; only interesting case is RATIONAL/INTEGER, since RATIONAL includes +;;; INTEGER. +;;; +;;; We make the result lower (upper) bound the maximum (minimum) of +;;; the argument lower (upper) bounds. We convert the bounds into the +;;; appropriate numeric type before maximizing. This avoids possible +;;; confusion due to mixed-type comparisons (but I think the result is +;;; the same). +(define-type-method (number :simple-intersection2) (type1 type2) + (declare (type numeric-type type1 type2)) + (if (numeric-types-intersect type1 type2) + (let* ((class1 (numeric-type-class type1)) + (class2 (numeric-type-class type2)) + (class (ecase class1 + ((nil) class2) + ((integer float) class1) + (rational (if (eq class2 'integer) + 'integer + 'rational)))) + (format (or (numeric-type-format type1) + (numeric-type-format type2)))) + (make-numeric-type + :class class + :format format + :complexp (or (numeric-type-complexp type1) + (numeric-type-complexp type2)) + :low (numeric-bound-max + (round-numeric-bound (numeric-type-low type1) + class format t) + (round-numeric-bound (numeric-type-low type2) + class format t) + > >= nil) + :high (numeric-bound-max + (round-numeric-bound (numeric-type-high type1) + class format nil) + (round-numeric-bound (numeric-type-high type2) + class format nil) + < <= nil))) + *empty-type*)) + +;;; Given two float formats, return the one with more precision. If +;;; either one is null, return NIL. +(defun float-format-max (f1 f2) + (when (and f1 f2) + (dolist (f *float-formats* (error "bad float format: ~S" f1)) + (when (or (eq f f1) (eq f f2)) + (return f))))) + +;;; Return the result of an operation on TYPE1 and TYPE2 according to +;;; the rules of numeric contagion. This is NUMBER, some float +;;; format (possibly complex) or RATIONAL or a UNION-TYPE of +;;; these. Due to rational canonicalization, there isn't much we can +;;; do here with integers or rational complex numbers. +;;; +;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This +;;; is useful mainly for allowing types that are technically numbers, +;;; but not a NUMERIC-TYPE. +(defun numeric-contagion (type1 type2) + (if (and (numeric-type-p type1) (numeric-type-p type2)) + (let ((class1 (numeric-type-class type1)) + (class2 (numeric-type-class type2)) + (format1 (numeric-type-format type1)) + (format2 (numeric-type-format type2)) + (complexp1 (numeric-type-complexp type1)) + (complexp2 (numeric-type-complexp type2))) + (cond ((eq class1 'float) + (make-numeric-type + :class 'float + :format (ecase class2 + (float (float-format-max format1 format2)) + ((integer rational) format1) + ((nil) + ;; A double-float with any real number is a + ;; double-float. + #-long-float + (if (eq format1 'double-float) + 'double-float + nil) + ;; A long-float with any real number is a + ;; long-float. + #+long-float + (if (eq format1 'long-float) + 'long-float + nil))) + :complexp (cond ((and (eq complexp1 :real) + (eq complexp2 :real)) + :real) + ((or (null complexp1) (null complexp2)) + nil) + (t :complex)))) + ((eq class2 'float) (numeric-contagion type2 type1)) + ((and (eq complexp1 :real) (eq complexp2 :real)) + (make-numeric-type + :class (and class1 class2 'rational) + :complexp :real)) + (t + (specifier-type 'number)))) + (specifier-type 'number))) + +;;;; array types + +(define-type-class array :enumerable nil :might-contain-other-types nil) + +;; All character-set types are enumerable, but it's not possible for +;; one to be TYPE= to a MEMBER type because (MEMBER #\x) is not +;; internally represented as a MEMBER type. So in case it wasn't +;; clear already ENUMERABLE-P does not mean "possibly a MEMBER type in +;; the Lisp-theoretic sense", but means "could be implemented in SBCL +;; as a MEMBER type". +(eval-when (#+sb-xc-host :compile-toplevel :load-toplevel :execute) + ;; may not get executed before LITERAL-CTYPE = LOAD-TIME-VALUE on + ;; host, since LOAD-TIME-VALUE execution order with respect to top + ;; level forms is unspecified. + (define-type-class character-set :enumerable nil :might-contain-other-types nil)) + +(defun make-character-set-type (pairs) + ; (aver (equal (mapcar #'car pairs) + ; (sort (mapcar #'car pairs) #'<))) + ;; aver that the cars of the list elements are sorted into increasing order + (when pairs + (do ((p pairs (cdr p))) + ((null (cdr p))) + (aver (<= (caar p) (caadr p))))) + (let ((pairs (let (result) + (do ((pairs pairs (cdr pairs))) + ((null pairs) (nreverse result)) + (destructuring-bind (low . high) (car pairs) + (loop for (low1 . high1) in (cdr pairs) + if (<= low1 (1+ high)) + do (progn (setf high (max high high1)) + (setf pairs (cdr pairs))) + else do (return nil)) + (cond + ((>= low char-code-limit)) + ((< high 0)) + (t (push (cons (max 0 low) + (min high (1- char-code-limit))) + result)))))))) + (unless pairs + (return-from make-character-set-type *empty-type*)) + (unless (cdr pairs) + (macrolet ((range (low high &optional saetp-index) + `(return-from make-character-set-type + (literal-ctype (!make-interned-character-set-type + (pack-interned-ctype-bits 'character-set nil ,saetp-index) + '((,low . ,high))) + (character-set ((,low . ,high))))))) + (let* ((pair (car pairs)) + (low (car pair)) + (high (cdr pair))) + (cond ((eql high (1- char-code-limit)) + (cond ((eql low 0) + (range 0 #.(1- char-code-limit) + (sb-vm::saetp-index-or-lose 'character))) + #+sb-unicode + ((eql low base-char-code-limit) + (range #.base-char-code-limit + #.(1- char-code-limit))))) + #+sb-unicode + ((and (eql low 0) (eql high (1- base-char-code-limit))) + (range 0 #.(1- base-char-code-limit) + (sb-vm::saetp-index-or-lose 'base-char))))))) + (%make-character-set-type pairs))) + +;; For all ctypes which are the element types of specialized arrays, +;; 3 ctype objects are stored for the rank-1 arrays of that specialization, +;; one for each of simple, maybe-simple, and non-simple (in that order), +;; and 2 ctype objects for unknown-rank arrays, one each for simple +;; and maybe-simple. (Unknown rank, known-non-simple isn't important) +#+sb-xc-host +(progn +(defvar *interned-array-types* + (labels ((make-1 (type-index dims complexp type) + (aver (= (type-saetp-index type) type-index)) + (!make-interned-array-type (pack-interned-ctype-bits 'array) + dims complexp type type)) + (make-all (element-type type-index array) + (replace array + (list (make-1 type-index '(*) nil element-type) + (make-1 type-index '(*) :maybe element-type) + (make-1 type-index '(*) t element-type) + (make-1 type-index '* nil element-type) + (make-1 type-index '* :maybe element-type)) + :start1 (* type-index 5))) + (integer-range (low high) + (make-numeric-type :class 'integer :complexp :real + :enumerable t :low low :high high))) + (let ((array (make-array (* 32 5))) + (index 0)) + ;; Index 31 is available to store *WILD-TYPE* + ;; because there are fewer than 32 array widetags. + (make-all *wild-type* 31 array) + (dovector (saetp sb-vm:*specialized-array-element-type-properties* + (progn (aver (< index 31)) array)) + (make-all + (let ((x (sb-vm:saetp-specifier saetp))) + ;; Produce element-type representation without parsing a spec. + ;; (SPECIFIER-TYPE doesn't work when bootstrapping.) + ;; The MAKE- constructors return an interned object as appropriate. + (etypecase x + ((cons (eql unsigned-byte)) + (integer-range 0 (1- (ash 1 (second x))))) + ((cons (eql signed-byte)) + (let ((lim (ash 1 (1- (second x))))) + (integer-range (- lim) (1- lim)))) + ((eql bit) (integer-range 0 1)) + ;; FIXNUM is its own thing, why? See comment in vm-array + ;; saying to "See the comment in PRIMITIVE-TYPE-AUX" + ((eql fixnum) ; One good kludge deserves another. + (integer-range most-negative-fixnum + most-positive-fixnum)) + ((member single-float double-float) + (make-numeric-type :class 'float :format x :complexp :real)) + ((cons (eql complex)) + (make-numeric-type :class 'float :format (cadr x) + :complexp :complex)) + ((eql character) + (make-character-set-type `((0 . ,(1- char-code-limit))))) + #+sb-unicode + ((eql base-char) + (make-character-set-type `((0 . ,(1- base-char-code-limit))))) + ((eql t) *universal-type*) + ((eql nil) *empty-type*))) + index + array) + (incf index))))) +(defvar *parsed-specialized-array-element-types* + (let ((a (make-array (length sb-vm:*specialized-array-element-type-properties*)))) + (loop for i below (length a) + do (setf (aref a i) (array-type-specialized-element-type + (aref *interned-array-types* (* i 5))))) + a))) + +(declaim (ftype (sfunction (t &key (:complexp t) + (:element-type t) + (:specialized-element-type t)) + ctype) make-array-type)) +(defun make-array-type (dimensions &key (complexp :maybe) element-type + (specialized-element-type *wild-type*)) + (if (and (eq element-type specialized-element-type) + (or (and (eq dimensions '*) (neq complexp t)) + (typep dimensions '(cons (eql *) null)))) + (let ((res (svref (literal-ctype-vector *interned-array-types*) + (+ (* (type-saetp-index element-type) 5) + (if (listp dimensions) 0 3) + (ecase complexp ((nil) 0) ((:maybe) 1) ((t) 2)))))) + (aver (eq (array-type-element-type res) element-type)) + res) + (%make-array-type dimensions + complexp element-type specialized-element-type))) + +(define-type-method (array :simple-=) (type1 type2) + (cond ((not (and (equal (array-type-dimensions type1) + (array-type-dimensions type2)) + (eq (array-type-complexp type1) + (array-type-complexp type2)))) + (values nil t)) + ((or (unknown-type-p (array-type-element-type type1)) + (unknown-type-p (array-type-element-type type2))) + (type= (array-type-element-type type1) + (array-type-element-type type2))) + (t + (values (type= (array-type-specialized-element-type type1) + (array-type-specialized-element-type type2)) + t)))) + +(define-type-method (array :negate) (type) + ;; FIXME (and hint to PFD): we're vulnerable here to attacks of the + ;; form "are (AND ARRAY (NOT (ARRAY T))) and (OR (ARRAY BIT) (ARRAY + ;; NIL) (ARRAY CHAR) ...) equivalent?" -- CSR, 2003-12-10 + ;; A symptom of the aforementioned is that the following are not TYPE= + ;; (AND (VECTOR T) (NOT SIMPLE-ARRAY)) ; an ARRAY-TYPE + ;; (AND (VECTOR T) (NOT SIMPLE-VECTOR)) ; an INTERSECTION-TYPE + ;; even though (VECTOR T) makes it so that the (NOT) clause in each can + ;; only provide one additional bit of information: that the vector + ;; is complex as opposed to simple. The rank and element-type are fixed. + (if (and (eq (array-type-dimensions type) '*) + (eq (array-type-complexp type) 't) + (eq (array-type-element-type type) *wild-type*)) + ;; (NOT ) = either SIMPLE-ARRAY or (NOT ARRAY). + ;; This is deliberately asymmetric - trying to say that NOT simple-array + ;; equals hairy-array leads to infinite recursion. + (type-union (make-array-type '* :complexp nil + :element-type *wild-type*) + (make-negation-type + (make-array-type '* :element-type *wild-type*))) + (make-negation-type type))) + +(define-type-method (array :unparse) (type) + (let* ((dims (array-type-dimensions type)) + ;; Compare the specialised element type and the + ;; derived element type. If the derived type + ;; is so small that it jumps to a smaller upgraded + ;; element type, use the specialised element type. + ;; + ;; This protects from unparsing + ;; (and (vector (or bit symbol)) + ;; (vector (or bit character))) + ;; i.e., the intersection of two T array types, + ;; as a bit vector. + (stype (array-type-specialized-element-type type)) + (dtype (array-type-element-type type)) + (utype (%upgraded-array-element-type dtype)) + (eltype (type-specifier (if (type= stype utype) + dtype + stype))) + (complexp (array-type-complexp type))) + (cond ((eq dims '*) + (if (eq eltype '*) + (ecase complexp + ((t) '(and array (not simple-array))) + ((:maybe) 'array) + ((nil) 'simple-array)) + (ecase complexp + ((t) `(and (array ,eltype) (not simple-array))) + ((:maybe) `(array ,eltype)) + ((nil) `(simple-array ,eltype))))) + ((= (length dims) 1) + (if complexp + (let ((answer + (if (eq (car dims) '*) + (case eltype + (bit 'bit-vector) + ((base-char #-sb-unicode character) 'base-string) + (* 'vector) + (t `(vector ,eltype))) + (case eltype + (bit `(bit-vector ,(car dims))) + ((base-char #-sb-unicode character) + `(base-string ,(car dims))) + (t `(vector ,eltype ,(car dims))))))) + (if (eql complexp :maybe) + answer + `(and ,answer (not simple-array)))) + (if (eq (car dims) '*) + (case eltype + (bit 'simple-bit-vector) + ((base-char #-sb-unicode character) 'simple-base-string) + ((t) 'simple-vector) + (t `(simple-array ,eltype (*)))) + (case eltype + (bit `(simple-bit-vector ,(car dims))) + ((base-char #-sb-unicode character) + `(simple-base-string ,(car dims))) + ((t) `(simple-vector ,(car dims))) + (t `(simple-array ,eltype ,dims)))))) + (t + (ecase complexp + ((t) `(and (array ,eltype ,dims) (not simple-array))) + ((:maybe) `(array ,eltype ,dims)) + ((nil) `(simple-array ,eltype ,dims))))))) + +(define-type-method (array :simple-subtypep) (type1 type2) + (let ((dims1 (array-type-dimensions type1)) + (dims2 (array-type-dimensions type2)) + (complexp2 (array-type-complexp type2))) + (cond (;; not subtypep unless dimensions are compatible + (not (or (eq dims2 '*) + (and (not (eq dims1 '*)) + ;; (sbcl-0.6.4 has trouble figuring out that + ;; DIMS1 and DIMS2 must be lists at this + ;; point, and knowing that is important to + ;; compiling EVERY efficiently.) + (= (length (the list dims1)) + (length (the list dims2))) + (every (lambda (x y) + (or (eq y '*) (eql x y))) + (the list dims1) + (the list dims2))))) + (values nil t)) + ;; not subtypep unless complexness is compatible + ((not (or (eq complexp2 :maybe) + (eq (array-type-complexp type1) complexp2))) + (values nil t)) + ;; Since we didn't fail any of the tests above, we win + ;; if the TYPE2 element type is wild. + ((eq (array-type-element-type type2) *wild-type*) + (values t t)) + (;; Since we didn't match any of the special cases above, if + ;; either element type is unknown we can only give a good + ;; answer if they are the same. + (or (unknown-type-p (array-type-element-type type1)) + (unknown-type-p (array-type-element-type type2))) + (if (type= (array-type-element-type type1) + (array-type-element-type type2)) + (values t t) + (values nil nil))) + (;; Otherwise, the subtype relationship holds iff the + ;; types are equal, and they're equal iff the specialized + ;; element types are identical. + t + (values (type= (array-type-specialized-element-type type1) + (array-type-specialized-element-type type2)) + t))))) + +(!define-superclasses array ((vector vector) (array)) !cold-init-forms) + +(defun array-types-intersect (type1 type2) + (declare (type array-type type1 type2)) + (let ((dims1 (array-type-dimensions type1)) + (dims2 (array-type-dimensions type2)) + (complexp1 (array-type-complexp type1)) + (complexp2 (array-type-complexp type2))) + ;; See whether dimensions are compatible. + (cond ((not (or (eq dims1 '*) (eq dims2 '*) + (and (= (length dims1) (length dims2)) + (every (lambda (x y) + (or (eq x '*) (eq y '*) (= x y))) + dims1 dims2)))) + (values nil t)) + ;; See whether complexpness is compatible. + ((not (or (eq complexp1 :maybe) + (eq complexp2 :maybe) + (eq complexp1 complexp2))) + (values nil t)) + ;; Old comment: + ;; + ;; If either element type is wild, then they intersect. + ;; Otherwise, the types must be identical. + ;; + ;; FIXME: There seems to have been a fair amount of + ;; confusion about the distinction between requested element + ;; type and specialized element type; here is one of + ;; them. If we request an array to hold objects of an + ;; unknown type, we can do no better than represent that + ;; type as an array specialized on wild-type. We keep the + ;; requested element-type in the -ELEMENT-TYPE slot, and + ;; *WILD-TYPE* in the -SPECIALIZED-ELEMENT-TYPE. So, here, + ;; we must test for the SPECIALIZED slot being *WILD-TYPE*, + ;; not just the ELEMENT-TYPE slot. Maybe the return value + ;; in that specific case should be T, NIL? Or maybe this + ;; function should really be called + ;; ARRAY-TYPES-COULD-POSSIBLY-INTERSECT? In any case, this + ;; was responsible for bug #123, and this whole issue could + ;; do with a rethink and/or a rewrite. -- CSR, 2002-08-21 + ((or (eq (array-type-specialized-element-type type1) *wild-type*) + (eq (array-type-specialized-element-type type2) *wild-type*) + (type= (array-type-specialized-element-type type1) + (array-type-specialized-element-type type2))) + + (values t t)) + (t + (values nil t))))) + +(defun unite-array-types-complexp (type1 type2) + (let ((complexp1 (array-type-complexp type1)) + (complexp2 (array-type-complexp type2))) + (cond + ((eq complexp1 complexp2) + ;; both types are the same complexp-ity + (values complexp1 t)) + ((eq complexp1 :maybe) + ;; type1 is wild-complexp + (values :maybe type1)) + ((eq complexp2 :maybe) + ;; type2 is wild-complexp + (values :maybe type2)) + (t + ;; both types partition the complexp-space + (values :maybe nil))))) + +(defun unite-array-types-dimensions (type1 type2) + (let ((dims1 (array-type-dimensions type1)) + (dims2 (array-type-dimensions type2))) + (cond ((equal dims1 dims2) + ;; both types are same dimensionality + (values dims1 t)) + ((eq dims1 '*) + ;; type1 is wild-dimensions + (values '* type1)) + ((eq dims2 '*) + ;; type2 is wild-dimensions + (values '* type2)) + ((not (= (length dims1) (length dims2))) + ;; types have different number of dimensions + (values :incompatible nil)) + (t + ;; we need to check on a per-dimension basis + (let* ((supertype1 t) + (supertype2 t) + (compatible t) + (result (mapcar (lambda (dim1 dim2) + (cond + ((equal dim1 dim2) + dim1) + ((eq dim1 '*) + (setf supertype2 nil) + '*) + ((eq dim2 '*) + (setf supertype1 nil) + '*) + (t + (setf compatible nil)))) + dims1 dims2))) + (cond + ((or (not compatible) + (and (not supertype1) + (not supertype2))) + (values :incompatible nil)) + ((and supertype1 supertype2) + (values result supertype1)) + (t + (values result (if supertype1 type1 type2))))))))) + +(defun unite-array-types-element-types (type1 type2) + ;; FIXME: We'd love to be able to unite the full set of specialized + ;; array element types up to *wild-type*, but :simple-union2 is + ;; performed pairwise, so we don't have a good hook for it and our + ;; representation doesn't allow us to easily detect the situation + ;; anyway. + ;; But see SIMPLIFY-ARRAY-UNIONS which is able to do something like that. + (let* ((eltype1 (array-type-element-type type1)) + (eltype2 (array-type-element-type type2)) + (stype1 (array-type-specialized-element-type type1)) + (stype2 (array-type-specialized-element-type type2)) + (wild1 (eq eltype1 *wild-type*)) + (wild2 (eq eltype2 *wild-type*))) + (cond + ((and wild1 wild2) + (values eltype1 stype1 t)) + (wild1 + (values eltype1 stype1 type1)) + (wild2 + (values eltype2 stype2 type2)) + ((type= eltype1 eltype2) + (values eltype1 stype1 t)) + ((not (type= stype1 stype2)) + ;; non-wild types that don't share UAET don't unite + (values :incompatible nil nil)) + ((csubtypep eltype1 eltype2) + (values eltype2 stype2 type2)) + ((csubtypep eltype2 eltype1) + (values eltype1 stype1 type1)) + (t + (values :incompatible nil nil))))) + +(defun unite-array-types-supertypes-compatible-p (&rest supertypes) + ;; supertypes are compatible if they are all T, if there is a single + ;; NIL and all the rest are T, or if all non-T supertypes are the + ;; same and not NIL. + (let ((interesting-supertypes + (remove t supertypes))) + (or (not interesting-supertypes) + (equal interesting-supertypes '(nil)) + ;; supertypes are (OR BOOLEAN ARRAY-TYPE), so... + (typep (remove-duplicates interesting-supertypes) + '(cons array-type null))))) + +(define-type-method (array :simple-union2) (type1 type2) + (multiple-value-bind + (result-eltype result-stype eltype-supertype) + (unite-array-types-element-types type1 type2) + (multiple-value-bind + (result-complexp complexp-supertype) + (unite-array-types-complexp type1 type2) + (multiple-value-bind + (result-dimensions dimensions-supertype) + (unite-array-types-dimensions type1 type2) + (when (and (not (eq result-dimensions :incompatible)) + (not (eq result-eltype :incompatible)) + (unite-array-types-supertypes-compatible-p + eltype-supertype complexp-supertype dimensions-supertype)) + (make-array-type result-dimensions + :complexp result-complexp + :element-type result-eltype + :specialized-element-type result-stype)))))) + +(define-type-method (array :simple-intersection2) (type1 type2) + (declare (type array-type type1 type2)) + (if (array-types-intersect type1 type2) + (let ((dims1 (array-type-dimensions type1)) + (dims2 (array-type-dimensions type2)) + (complexp1 (array-type-complexp type1)) + (complexp2 (array-type-complexp type2)) + (eltype1 (array-type-element-type type1)) + (eltype2 (array-type-element-type type2)) + (stype1 (array-type-specialized-element-type type1)) + (stype2 (array-type-specialized-element-type type2))) + (make-array-type (cond ((eq dims1 '*) dims2) + ((eq dims2 '*) dims1) + (t + (mapcar (lambda (x y) (if (eq x '*) y x)) + dims1 dims2))) + :complexp (if (eq complexp1 :maybe) complexp2 complexp1) + :element-type (cond + ((eq eltype1 *wild-type*) eltype2) + ((eq eltype2 *wild-type*) eltype1) + (t (type-intersection eltype1 eltype2))) + :specialized-element-type (cond + ((eq stype1 *wild-type*) stype2) + ((eq stype2 *wild-type*) stype1) + (t + (aver (type= stype1 stype2)) + stype1)))) + *empty-type*)) + +;;; Check a supplied dimension list to determine whether it is legal, +;;; and return it in canonical form (as either '* or a list). +(defun canonical-array-dimensions (dims) + (typecase dims + ((member *) dims) + (integer + (when (minusp dims) + (error "Arrays can't have a negative number of dimensions: ~S" dims)) + (when (>= dims array-rank-limit) + (error "array type with too many dimensions: ~S" dims)) + (make-list dims :initial-element '*)) + (list + (when (>= (length dims) array-rank-limit) + (error "array type with too many dimensions: ~S" dims)) + (dolist (dim dims) + (unless (eq dim '*) + (unless (and (integerp dim) + (>= dim 0) + (< dim array-dimension-limit)) + (error "bad dimension in array type: ~S" dim)))) + dims) + (t + (error "Array dimensions is not a list, integer or *:~% ~S" dims)))) + +;;;; MEMBER types + + +(define-type-class member :enumerable t + :might-contain-other-types nil) + +(declaim (ftype (sfunction (xset list) ctype) make-member-type)) +(defun member-type-from-list (members) + (let ((xset (alloc-xset)) + (fp-zeroes)) + (dolist (elt members (make-member-type xset fp-zeroes)) + (if (fp-zero-p elt) + (pushnew elt fp-zeroes) + (add-to-xset elt xset))))) +(defun make-eql-type (elt) (member-type-from-list (list elt))) +;; Return possibly a union of a MEMBER type and a NUMERIC type, +;; or just one or the other, or *EMPTY-TYPE* depending on what's in the XSET +;; and the FP-ZEROES. XSET should not contains characters or real numbers. +(defun make-member-type (xset fp-zeroes) + ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can + ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric + ;; ranges are compared by arithmetic operators (while MEMBERship is + ;; compared by EQL). -- CSR, 2003-04-23 + (let ((presence 0) + (unpaired nil) + (float-types nil)) + (when fp-zeroes ; avoid doing two passes of nothing + (dotimes (pass 2) + (dolist (z fp-zeroes) + (let ((sign (float-sign-bit z)) + (pair-idx + (etypecase z + (single-float 0) + (double-float 2 + #+long-float (long-float 4))))) + (if (= pass 0) + (setf (ldb (byte 1 (+ pair-idx sign)) presence) 1) + (if (= (ldb (byte 2 pair-idx) presence) #b11) + (when (= sign 0) + (push (ctype-of z) float-types)) + (push z unpaired))))))) + (let ((member-type + (block nil + (unless unpaired + (macrolet ((member-type (&rest elts) + `(literal-ctype + (!make-interned-member-type + (pack-interned-ctype-bits 'member) (xset-from-list ',elts) nil) + (member ,@elts)))) + (let ((elts (xset-data xset))) + (when (singleton-p elts) + (case (first elts) + ((nil) (return (member-type nil))) + ((t) (return (member-type t))))) + (when (or (equal elts '(t nil)) (equal elts '(nil t))) + ;; Semantically this is fine - XSETs + ;; are not order-preserving except by accident + ;; (when not represented as a hash-table). + (return (member-type t nil)))))) + (when (or unpaired (not (xset-empty-p xset))) + (%make-member-type xset unpaired))))) + ;; The actual member-type contains the XSET (with no FP zeroes), + ;; and a list of unpaired zeroes. + (if float-types + (make-union-type t (if member-type + (cons member-type float-types) + float-types)) + (or member-type *empty-type*))))) + +(defun member-type-size (type) + (+ (length (member-type-fp-zeroes type)) + (xset-count (member-type-xset type)))) + +(defun member-type-member-p (x type) + (if (fp-zero-p x) + (and (member x (member-type-fp-zeroes type)) t) + (xset-member-p x (member-type-xset type)))) + +(defun mapcar-member-type-members (function type) + (declare (function function)) + (collect ((results)) + (map-xset (lambda (x) + (results (funcall function x))) + (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (results (funcall function zero))) + (results))) + +(defun mapc-member-type-members (function type) + (declare (function function)) + (map-xset function (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (funcall function zero))) + +(defun member-type-members (type) + (append (member-type-fp-zeroes type) + (xset-members (member-type-xset type)))) + +(define-type-method (member :negate) (type) + (let ((xset (member-type-xset type)) + (fp-zeroes (member-type-fp-zeroes type))) + (if fp-zeroes + ;; Hairy case, which needs to do a bit of float type + ;; canonicalization. + (apply #'type-intersection + (if (xset-empty-p xset) + *universal-type* + (make-negation-type (make-member-type xset nil))) + (mapcar + (lambda (x) + (let* ((opposite (sb-xc:- x)) + (type (ctype-of opposite))) + (type-union + (make-negation-type + (modified-numeric-type type :low nil :high nil)) + (modified-numeric-type type :low nil :high (list opposite)) + (make-eql-type opposite) + (modified-numeric-type type :low (list opposite) :high nil)))) + fp-zeroes)) + ;; Easy case + (make-negation-type type)))) + +(define-type-method (member :unparse) (type) + (cond ((eq type (specifier-type 'null)) 'null) ; NULL type is EQ-comparable + ((eq type (specifier-type 'boolean)) 'boolean) ; so is BOOLEAN + (t `(member ,@(member-type-members type))))) + +(define-type-method (member :singleton-p) (type) + (if (eql 1 (member-type-size type)) + (values t (first (member-type-members type))) + (values nil nil))) + +(define-type-method (member :simple-subtypep) (type1 type2) + (values (and (xset-subset-p (member-type-xset type1) + (member-type-xset type2)) + (subsetp (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2))) + t)) + +(define-type-method (member :complex-subtypep-arg1) (type1 type2) + (block punt + (mapc-member-type-members + (lambda (elt) + (multiple-value-bind (ok surep) (ctypep elt type2) + (unless surep + (return-from punt (values nil nil))) + (unless ok + (return-from punt (values nil t))))) + type1) + (values t t))) + +;;; We punt if the odd type is enumerable and intersects with the +;;; MEMBER type. If not enumerable, then it is definitely not a +;;; subtype of the MEMBER type. +(define-type-method (member :complex-subtypep-arg2) (type1 type2) + (cond ((not (type-enumerable type1)) (values nil t)) + ((types-equal-or-intersect type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) + (t (values nil t)))) + +(define-type-method (member :simple-intersection2) (type1 type2) + (make-member-type (xset-intersection (member-type-xset type1) + (member-type-xset type2)) + (intersection (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2)))) + +(define-type-method (member :complex-intersection2) (type1 type2) + (block punt + (let ((xset (alloc-xset)) + (fp-zeroes nil)) + (mapc-member-type-members + (lambda (member) + (multiple-value-bind (ok sure) (ctypep member type1) + (unless sure + (return-from punt nil)) + (when ok + (if (fp-zero-p member) + (pushnew member fp-zeroes) + (add-to-xset member xset))))) + type2) + (if (and (xset-empty-p xset) (not fp-zeroes)) + *empty-type* + (make-member-type xset fp-zeroes))))) + +;;; We don't need a :COMPLEX-UNION2, since the only interesting case is +;;; a union type, and the member/union interaction is handled by the +;;; union type method. +(define-type-method (member :simple-union2) (type1 type2) + (make-member-type (xset-union (member-type-xset type1) + (member-type-xset type2)) + (union (member-type-fp-zeroes type1) + (member-type-fp-zeroes type2)))) + +(define-type-method (member :simple-=) (type1 type2) + (let ((xset1 (member-type-xset type1)) + (xset2 (member-type-xset type2)) + (l1 (member-type-fp-zeroes type1)) + (l2 (member-type-fp-zeroes type2))) + (values (and (eql (xset-count xset1) (xset-count xset2)) + (xset-subset-p xset1 xset2) + (xset-subset-p xset2 xset1) + (subsetp l1 l2) + (subsetp l2 l1)) + t))) + +(define-type-method (member :complex-=) (type1 type2) + (if (type-enumerable type1) + (multiple-value-bind (val win) (csubtypep type2 type1) + (if (or val (not win)) + (values nil nil) + (values nil t))) + (values nil t))) + +(def-type-translator member :list (&rest members) + ;; "* may appear as an argument to a MEMBER type specifier, but it indicates the + ;; literal symbol *, and does not represent an unspecified value." + (if members + (let (ms numbers char-codes) + (dolist (m (remove-duplicates members)) + (typecase m + (character (push (sb-xc:char-code m) char-codes)) + (real (if (and (floatp m) (zerop m)) + (push m ms) + (push (ctype-of m) numbers))) + (t (push m ms)))) + (apply #'type-union + (member-type-from-list ms) + (make-character-set-type (mapcar (lambda (x) (cons x x)) + (sort char-codes #'<))) + (nreverse numbers))) + *empty-type*)) + +;;;; intersection types +;;;; +;;;; Until version 0.6.10.6, SBCL followed the original CMU CL approach +;;;; of punting on all AND types, not just the unreasonably complicated +;;;; ones. The change was motivated by trying to get the KEYWORD type +;;;; to behave sensibly: +;;;; ;; reasonable definition +;;;; (DEFTYPE KEYWORD () '(AND SYMBOL (SATISFIES KEYWORDP))) +;;;; ;; reasonable behavior +;;;; (AVER (SUBTYPEP 'KEYWORD 'SYMBOL)) +;;;; Without understanding a little about the semantics of AND, we'd +;;;; get (SUBTYPEP 'KEYWORD 'SYMBOL)=>NIL,NIL and, for entirely +;;;; parallel reasons, (SUBTYPEP 'RATIO 'NUMBER)=>NIL,NIL. That's +;;;; not so good..) +;;;; +;;;; We still follow the example of CMU CL to some extent, by punting +;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types +;;;; involving AND. + +(define-type-class intersection + :enumerable #'compound-type-enumerable + :might-contain-other-types t) + +(define-type-method (intersection :negate) (type) + (%type-union + (mapcar #'type-negation (intersection-type-types type)))) + +;;; A few intersection types have special names. The others just get +;;; mechanically unparsed. +(define-type-method (intersection :unparse) (type) + (declare (type ctype type)) + ;; If magic intersection types were interned, then + ;; we could compare by EQ here instead of calling TYPE= + (cond ((type= type (literal-ctype (specifier-type 'keyword) keyword)) + 'keyword) + ((type= type (literal-ctype (specifier-type 'ratio) ratio)) + 'ratio) + ((type= type (literal-ctype (specifier-type 'compiled-function) compiled-function)) + 'compiled-function) + (t + `(and ,@(mapcar #'type-specifier (intersection-type-types type)))))) + +(define-type-method (intersection :singleton-p) (type) + (loop for constituent in (intersection-type-types type) + do + (multiple-value-bind (single value) (type-singleton-p constituent) + (when single + (return (values single value)))) + finally (return (values nil nil)))) + +;;; shared machinery for type equality: true if every type in the set +;;; TYPES1 matches a type in the set TYPES2 and vice versa +(defun type=-set (types1 types2) + (flet ((type<=-set (x y) + (declare (type list x y)) + (every/type (lambda (x y-element) + (any/type #'type= y-element x)) + x y))) + (and/type (type<=-set types1 types2) + (type<=-set types2 types1)))) + +;;; Two intersection types are equal if their subtypes are equal sets. +;;; +;;; FIXME: Might it be better to use +;;; (AND (SUBTYPEP X Y) (SUBTYPEP Y X)) +;;; instead, since SUBTYPEP is the usual relationship that we care +;;; most about, so it would be good to leverage any ingenuity there +;;; in this more obscure method? +;;; +;;; Possibly yes, but then the SUBTYPEP methods would have to be +;;; rewritten not to use TYPE= (see the discussion around UNION +;;; :SIMPLE=) +(define-type-method (intersection :simple-=) (type1 type2) + (type=-set (intersection-type-types type1) + (intersection-type-types type2))) + +(define-type-method (intersection :complex-=) (type1 type2) + (let ((seen-uncertain nil)) + (dolist (itype (intersection-type-types type2) + (if seen-uncertain + (values nil nil) + (invoke-complex-=-other-method type1 type2))) + (let ((trial-intersection (type-intersection2 type1 itype))) + (if (null trial-intersection) + (setq seen-uncertain (type-might-contain-other-types-p itype)) + ;; C != (Ai n Aj...) if (C n Ai) < C. + ;; + ;; (CSUBTYPEP (AND C Ai) C) is T, T by construction. + ;; We ask (SUBTYPEP C (AND C Ai)): + ;; + ;; T , T : OK, continue -- C = (AND C Ai) + ;; NIL, T : return early -- C > (AND C Ai) + ;; NIL, NIL: don't know! If we get to the end, return NIL, NIL, but + ;; give other types in the intersection a chance to return + ;; early. + (multiple-value-bind (subtype certain?) + (csubtypep type1 trial-intersection) + (cond + ((not certain?) (setq seen-uncertain t)) + ((not subtype) (return (values nil t)))))))))) + +(defun %intersection-complex-subtypep-arg1 (type1 type2) + (type= type1 (type-intersection type1 type2))) + +(defun %intersection-simple-subtypep (type1 type2) + (every/type #'%intersection-complex-subtypep-arg1 + type1 + (intersection-type-types type2))) + +(define-type-method (intersection :simple-subtypep) (type1 type2) + (%intersection-simple-subtypep type1 type2)) + +(define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (%intersection-complex-subtypep-arg1 type1 type2)) + +(defun %intersection-complex-subtypep-arg2 (type1 type2) + (every/type #'csubtypep type1 (intersection-type-types type2))) + +(define-type-method (intersection :complex-subtypep-arg2) (type1 type2) + (%intersection-complex-subtypep-arg2 type1 type2)) + +;;; FIXME: This will look eeriely familiar to readers of the UNION +;;; :SIMPLE-INTERSECTION2 :COMPLEX-INTERSECTION2 method. That's +;;; because it was generated by cut'n'paste methods. Given that +;;; intersections and unions have all sorts of symmetries known to +;;; mathematics, it shouldn't be beyond the ken of some programmers to +;;; reflect those symmetries in code in a way that ties them together +;;; more strongly than having two independent near-copies :-/ +(define-type-method (intersection :simple-union2 :complex-union2) + (type1 type2) + ;; Within this method, type2 is guaranteed to be an intersection + ;; type: + (aver (intersection-type-p type2)) + ;; Make sure to call only the applicable methods... + (cond ((and (intersection-type-p type1) + (%intersection-simple-subtypep type1 type2)) type2) + ((and (intersection-type-p type1) + (%intersection-simple-subtypep type2 type1)) type1) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg2 type1 type2)) + type2) + ((and (not (intersection-type-p type1)) + (%intersection-complex-subtypep-arg1 type2 type1)) + type1) + ;; KLUDGE: This special (and somewhat hairy) magic is required + ;; to deal with the RATIONAL/INTEGER special case. The UNION + ;; of (INTEGER * -1) and (AND (RATIONAL * -1/2) (NOT INTEGER)) + ;; should be (RATIONAL * -1/2) -- CSR, 2003-02-28 + ((and (csubtypep type2 (specifier-type 'ratio)) + (numeric-type-p type1) + (csubtypep type1 (specifier-type 'integer)) + (csubtypep type2 + (make-numeric-type + :class 'rational + :complexp nil + :low (if (null (numeric-type-low type1)) + nil + (list (1- (numeric-type-low type1)))) + :high (if (null (numeric-type-high type1)) + nil + (list (1+ (numeric-type-high type1))))))) + (let* ((intersected (intersection-type-types type2)) + (remaining (remove (specifier-type '(not integer)) + intersected + :test #'type=))) + (and (not (equal intersected remaining)) + (type-union type1 (%type-intersection remaining))))) + (t + (let ((accumulator *universal-type*)) + (do ((t2s (intersection-type-types type2) (cdr t2s))) + ((null t2s) accumulator) + (let ((union (type-union type1 (car t2s)))) + (when (union-type-p union) + ;; we have to give up here -- there are all sorts of + ;; ordering worries, but it's better than before. + ;; Doing exactly the same as in the UNION + ;; :SIMPLE/:COMPLEX-INTERSECTION2 method causes stack + ;; overflow with the mutual recursion never bottoming + ;; out. + (if (and (eq accumulator *universal-type*) + (null (cdr t2s))) + ;; KLUDGE: if we get here, we have a partially + ;; simplified result. While this isn't by any + ;; means a universal simplification, including + ;; this logic here means that we can get (OR + ;; KEYWORD (NOT KEYWORD)) canonicalized to T. + (return union) + (return nil))) + (setf accumulator + (type-intersection accumulator union)))))))) + +(def-type-translator and :list ((:context context) &rest type-specifiers) + ;; "* is not permitted as an argument to the AND type specifier." + (%type-intersection (mapcar (lambda (x) (specifier-type x context 'and)) + type-specifiers))) + +;;;; union types + +(define-type-class union + :enumerable #'compound-type-enumerable + :might-contain-other-types t) + +(define-type-method (union :negate) (type) + (declare (type ctype type)) + (%type-intersection (mapcar #'type-negation (union-type-types type)))) + +;;; Unlike ARRAY-TYPE-DIMENSIONS this handles union types, which +;;; includes the type STRING. +(defun ctype-array-dimensions (type) + (labels ((process-compound-type (types) + (let (dimensions) + (dolist (type types) + (unless (or (hairy-type-p type) + (negation-type-p type)) + (let ((current-dimensions (determine type))) + (cond ((eq current-dimensions '*) + (return-from ctype-array-dimensions '*)) + ((and dimensions + (not (equal current-dimensions dimensions))) + (if (= (length dimensions) + (length current-dimensions)) + (setf dimensions + (loop for dimension in dimensions + for current-dimension in current-dimensions + collect (if (eql dimension current-dimension) + dimension + '*))) + (return-from ctype-array-dimensions '*))) + (t + + (setf dimensions current-dimensions)))))) + dimensions)) + (determine (type) + (etypecase type + (array-type + (array-type-dimensions type)) + (union-type + (process-compound-type (union-type-types type))) + (member-type + (process-compound-type + (mapcar #'ctype-of (member-type-members type)))) + (intersection-type + (process-compound-type (intersection-type-types type)))))) + (determine type))) + +(defun ctype-array-specialized-element-types (type) + (let (types) + (labels ((process-compound-type (types) + (loop for type in types + unless (or (hairy-type-p type) + (negation-type-p type)) + do (determine type))) + (determine (type) + (etypecase type + (array-type + (when (eq (array-type-specialized-element-type type) *wild-type*) + (return-from ctype-array-specialized-element-types + *wild-type*)) + (pushnew (array-type-specialized-element-type type) + types :test #'type=)) + (union-type + (process-compound-type (union-type-types type))) + (intersection-type + (process-compound-type (intersection-type-types type))) + (member-type + (process-compound-type + (mapcar #'ctype-of (member-type-members type))))))) + (determine type)) + types)) + +;;; Union unparsing involves looking for certain important type atoms in our +;;; internal representation - a/k/a "interned types" - those which have a unique +;;; object that models them; and then deciding whether some conjunction of +;;; particular atoms unparses to a prettier symbolic type. +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *special-union-types* + ;; This is order-sensitive. Prefer to recognize SEQUENCE + ;; and extract 4 components (NULL,CONS,VECTOR,EXTENDED-SEQUENCE) + ;; before considering LIST and extracting 2, etc. + '(sequence list real float complex bignum))) + +(define-type-method (union :unparse) (type) + ;; This logic diverges between +/- sb-xc-host because the machinery + ;; to parse types is obviously not usable here during make-host-1, + ;; so the macro has to generate code that is lazier about parsing. + (collect ((recognized)) + (let ((remainder (copy-list (union-type-types type)))) + #+sb-xc-host + ;; Try to recognize each special type in order. + ;; Don't use SUBTYPEP here; compare atoms instead. We're not trying + ;; to answer complicated questions - only see whether the argument TYPE + ;; contains (at least) each of the exact same things in SPECIAL. + (dolist (special *special-union-types*) + (let ((parts (union-type-types (specifier-type special)))) + (when (every (lambda (part) (memq part remainder)) parts) + ;; Remove the parts from the remainder + (dolist (part parts) (setq remainder (delq1 part remainder))) + (recognized special)))) ; add to the output + #-sb-xc-host + (macrolet + ((generator () + (let* ((constituent-types + (mapcar (lambda (type-specifier) + (union-type-types (specifier-type type-specifier))) + *special-union-types*)) + ;; Get the set of atoms that we need to pick out + (atoms (remove-duplicates (apply #'append constituent-types)))) + (labels ((atom->bit (atom) (ash 1 (position atom atoms))) + (compute-mask (parts) (apply #'+ (mapcar #'atom->bit parts)))) + `(let ((bits 0)) + (dolist (part remainder) + (setq bits + (logior bits + (cond ,@(mapcar (lambda (atom) + `((eq part ,atom) ,(atom->bit atom))) + atoms) + (t 0))))) + ;; Now we have a bitmask of all the interesting type atoms in the + ;; compound type. Try to match sets of bits, and remember it is + ;; possible to match more than one set, + ;; e.g. (OR STRING FLOAT BIGNUM) matches 3 pairs of bits. + ,@(mapcar (lambda (name parts &aux (mask (compute-mask parts))) + `(when (= (logand bits ,mask) ,mask) ; is all of these + (setq bits (logand bits ,(lognot mask))) ; Subtract the bits + ,@(mapcar (lambda (atom) + `(setq remainder (delq1 ,atom remainder))) + parts) + (recognized ',name))) ; add to the output + *special-union-types* constituent-types)))))) + (generator)) + ;; See if we can pair any two constituent types that resolve to + ;; ({STRING|SIMPLE-STRING|non-SIMPLE-STRING} n). + ;; Repeat until there are no more pairs. This is a kludge. + #+sb-unicode + (loop for tail on remainder + do (let* ((x (car tail)) + (peer + (and (array-type-p x) ; If X is a CHARACTER vector + (eq (array-type-element-type x) (specifier-type 'character)) + (singleton-p (array-type-dimensions x)) + ;; And can be matched with a BASE-CHAR vector + (member-if (lambda (y) + (and (array-type-p y) + (eq (array-type-element-type y) + (specifier-type 'base-char)) + (eq (array-type-complexp y) + (array-type-complexp x)) + (equal (array-type-dimensions y) + (array-type-dimensions x)))) + (cdr tail))))) + (when peer ; then together they comprise a subtype of STRING + (let* ((dim (car (array-type-dimensions x))) + (string-type + (if (array-type-complexp x) + (if (eq dim '*) 'string `(string ,dim)) + (if (eq dim '*) 'simple-string `(simple-string ,dim))))) + (recognized (if (eq (array-type-complexp x) 't) + `(and ,string-type (not simple-array)) + string-type))) + (rplaca tail nil) ; We'll delete these list elements later + (rplaca peer nil)))) + (let ((list (nconc (recognized) + (mapcar #'type-specifier (delete nil remainder))))) + (if (cdr list) `(or ,@list) (car list)))))) + +;;; Two union types are equal if they are each subtypes of each +;;; other. We need to be this clever because our complex subtypep +;;; methods are now more accurate; we don't get infinite recursion +;;; because the simple-subtypep method delegates to complex-subtypep +;;; of the individual types of type1. - CSR, 2002-04-09 +;;; +;;; Previous comment, now obsolete, but worth keeping around because +;;; it is true, though too strong a condition: +;;; +;;; Two union types are equal if their subtypes are equal sets. +(define-type-method (union :simple-=) (type1 type2) + (multiple-value-bind (subtype certain?) + (csubtypep type1 type2) + (if subtype + (csubtypep type2 type1) + ;; we might as well become as certain as possible. + (if certain? + (values nil t) + (multiple-value-bind (subtype certain?) + (csubtypep type2 type1) + (values nil (and (not subtype) certain?))))))) + +(define-type-method (union :complex-=) (type1 type2) + (declare (ignore type1)) + (if (some #'type-might-contain-other-types-p + (union-type-types type2)) + (values nil nil) + (values nil t))) + +;;; Similarly, a union type is a subtype of another if and only if +;;; every element of TYPE1 is a subtype of TYPE2. +(defun union-simple-subtypep (type1 type2) + (every/type (swapped-args-fun #'union-complex-subtypep-arg2) + type2 + (union-type-types type1))) + +(define-type-method (union :simple-subtypep) (type1 type2) + (union-simple-subtypep type1 type2)) + +(defun union-complex-subtypep-arg1 (type1 type2) + (every/type (swapped-args-fun #'csubtypep) + type2 + (union-type-types type1))) + +(define-type-method (union :complex-subtypep-arg1) (type1 type2) + (union-complex-subtypep-arg1 type1 type2)) + +(defun union-complex-subtypep-arg2 (type1 type2) + ;; At this stage, we know that type2 is a union type and type1 + ;; isn't. We might as well check this, though: + (aver (union-type-p type2)) + (aver (not (union-type-p type1))) + ;; was: (any/type #'csubtypep type1 (union-type-types type2)), which + ;; turns out to be too restrictive, causing bug 91. + ;; + ;; the following reimplementation might look dodgy. It is dodgy. It + ;; depends on the union :complex-= method not doing very much work + ;; -- certainly, not using subtypep. Reasoning: + ;; + ;; A is a subset of (B1 u B2) + ;; <=> A n (B1 u B2) = A + ;; <=> (A n B1) u (A n B2) = A + ;; + ;; But, we have to be careful not to delegate this type= to + ;; something that could invoke subtypep, which might get us back + ;; here -> stack explosion. We therefore ensure that the second type + ;; (which is the one that's dispatched on) is either a union type + ;; (where we've ensured that the complex-= method will not call + ;; subtypep) or something with no union types involved, in which + ;; case we'll never come back here. + ;; + ;; If we don't do this, then e.g. + ;; (SUBTYPEP '(MEMBER 3) '(OR (SATISFIES FOO) (SATISFIES BAR))) + ;; would loop infinitely, as the member :complex-= method is + ;; implemented in terms of subtypep. + ;; + ;; Ouch. - CSR, 2002-04-10 + (cond ((fun-designator-type-p type1) + (type= type2 (specifier-type 'function-designator))) + (t + (multiple-value-bind (sub-value sub-certain?) + (type= type1 + (%type-union + (mapcar (lambda (x) (type-intersection type1 x)) + (union-type-types type2)))) + (if sub-certain? + (values sub-value sub-certain?) + ;; The ANY/TYPE expression above is a sufficient condition for + ;; subsetness, but not a necessary one, so we might get a more + ;; certain answer by this CALL-NEXT-METHOD-ish step when the + ;; ANY/TYPE expression is uncertain. + (invoke-complex-subtypep-arg1-method type1 type2)))))) + +(define-type-method (union :complex-subtypep-arg2) (type1 type2) + (union-complex-subtypep-arg2 type1 type2)) + +(define-type-method (union :simple-intersection2 :complex-intersection2) + (type1 type2) + ;; The CSUBTYPEP clauses here let us simplify e.g. + ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST) + ;; (SPECIFIER-TYPE '(OR LIST VECTOR))) + ;; (where LIST is (OR CONS NULL)). + ;; + ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice + ;; versa, but it's important that we pre-expand them into + ;; specialized operations on individual elements of + ;; UNION-TYPE-TYPES, instead of using the ordinary call to + ;; CSUBTYPEP, in order to avoid possibly invoking any methods which + ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus + ;; cause infinite recursion. + ;; + ;; Within this method, type2 is guaranteed to be a union type: + (aver (union-type-p type2)) + ;; Make sure to call only the applicable methods... + (cond ((and (union-type-p type1) + (union-simple-subtypep type1 type2)) type1) + ((and (union-type-p type1) + (union-simple-subtypep type2 type1)) type2) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg2 type1 type2)) + type1) + ((and (not (union-type-p type1)) + (union-complex-subtypep-arg1 type2 type1)) + type2) + (t + ;; KLUDGE: This code accumulates a sequence of TYPE-UNION2 + ;; operations in a particular order, and gives up if any of + ;; the sub-unions turn out not to be simple. In other cases + ;; ca. sbcl-0.6.11.15, that approach to taking a union was a + ;; bad idea, since it can overlook simplifications which + ;; might occur if the terms were accumulated in a different + ;; order. It's possible that that will be a problem here too. + ;; However, I can't think of a good example to demonstrate + ;; it, and without an example to demonstrate it I can't write + ;; test cases, and without test cases I don't want to + ;; complicate the code to address what's still a hypothetical + ;; problem. So I punted. -- WHN 2001-03-20 + (let ((accumulator *empty-type*)) + (dolist (t2 (union-type-types type2) accumulator) + (setf accumulator + (type-union accumulator + (type-intersection type1 t2)))))))) + +(def-type-translator or :list ((:context context) &rest type-specifiers) + ;; "* is not permitted as an argument to the OR type specifier." + (let ((type (%type-union (mapcar (lambda (x) (specifier-type x context 'or)) + type-specifiers)))) + (if (union-type-p type) + (sb-kernel::simplify-array-unions type) + type))) + + +;;;; ALIEN-TYPE types + +(define-type-class alien :enumerable nil :might-contain-other-types nil) + +(define-type-method (alien :negate) (type) (make-negation-type type)) + +(define-type-method (alien :unparse) (type) + `(alien ,(unparse-alien-type (alien-type-type-alien-type type)))) + +(define-type-method (alien :simple-subtypep) (type1 type2) + (values (alien-subtype-p (alien-type-type-alien-type type1) + (alien-type-type-alien-type type2)) + t)) + +(define-type-method (alien :simple-=) (type1 type2) + (let ((alien-type-1 (alien-type-type-alien-type type1)) + (alien-type-2 (alien-type-type-alien-type type2))) + (values (or (eq alien-type-1 alien-type-2) + (alien-type-= alien-type-1 alien-type-2)) + t))) + +(def-type-translator alien (&optional (alien-type nil)) + (typecase alien-type + (null + (make-alien-type-type)) + (alien-type + (make-alien-type-type alien-type)) + (t + (make-alien-type-type (parse-alien-type alien-type (make-null-lexenv)))))) + +(defun make-alien-type-type (&optional alien-type) + (if alien-type + (let ((lisp-rep-type (compute-lisp-rep-type alien-type))) + (if lisp-rep-type + (single-value-specifier-type lisp-rep-type) + (%make-alien-type-type alien-type))) + *universal-type*)) + + +;;;; CONS types + +(def-type-translator cons ((:context context) + &optional (car-type-spec '*) (cdr-type-spec '*)) + (let ((car-type (single-value-specifier-type car-type-spec context)) + (cdr-type (single-value-specifier-type cdr-type-spec context))) + (make-cons-type car-type cdr-type))) + +(define-type-class cons :enumerable nil :might-contain-other-types nil) + +#+sb-xc-host +(declaim (ftype (sfunction (ctype ctype) (values t t)) type=)) +(defun make-cons-type (car-type cdr-type) + (aver (not (or (eq car-type *wild-type*) + (eq cdr-type *wild-type*)))) + (cond ((or (eq car-type *empty-type*) + (eq cdr-type *empty-type*)) + *empty-type*) + ;; It's not a requirement that (CONS T T) be interned, + ;; but it improves the hit rate in the function caches. + ((and (type= car-type *universal-type*) + (type= cdr-type *universal-type*)) + (literal-ctype (!make-interned-cons-type (pack-interned-ctype-bits 'cons) + *universal-type* + *universal-type*) + cons)) + (t + (%make-cons-type car-type cdr-type)))) + +;;; Return TYPE converted to canonical form for a situation where the +;;; "type" '* (which SBCL still represents as a type even though ANSI +;;; CL defines it as a related but different kind of placeholder) is +;;; equivalent to type T. +(defun type-*-to-t (type) + (if (type= type *wild-type*) + *universal-type* + type)) + +(define-type-method (cons :negate) (type) + (if (and (eq (cons-type-car-type type) *universal-type*) + (eq (cons-type-cdr-type type) *universal-type*)) + (make-negation-type type) + (type-union + (make-negation-type (specifier-type 'cons)) + (cond + ((and (not (eq (cons-type-car-type type) *universal-type*)) + (not (eq (cons-type-cdr-type type) *universal-type*))) + (type-union + (make-cons-type + (type-negation (cons-type-car-type type)) + *universal-type*) + (make-cons-type + *universal-type* + (type-negation (cons-type-cdr-type type))))) + ((not (eq (cons-type-car-type type) *universal-type*)) + (make-cons-type + (type-negation (cons-type-car-type type)) + *universal-type*)) + ((not (eq (cons-type-cdr-type type) *universal-type*)) + (make-cons-type + *universal-type* + (type-negation (cons-type-cdr-type type)))) + (t (bug "Weird CONS type ~S" type)))))) + +(define-type-method (cons :unparse) (type) + (if (eq type (specifier-type 'cons)) + 'cons + `(cons ,(type-specifier (cons-type-car-type type)) + ,(type-specifier (cons-type-cdr-type type))))) + +(define-type-method (cons :simple-=) (type1 type2) + (declare (type cons-type type1 type2)) + (multiple-value-bind (car-match car-win) + (type= (cons-type-car-type type1) (cons-type-car-type type2)) + (multiple-value-bind (cdr-match cdr-win) + (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)) + (cond ((and car-match cdr-match) + (aver (and car-win cdr-win)) + (values t t)) + (t + (values nil + ;; FIXME: Ideally we would like to detect and handle + ;; (CONS UNKNOWN INTEGER) (CONS UNKNOWN SYMBOL) => NIL, T + ;; but just returning a secondary true on (and car-win cdr-win) + ;; unfortunately breaks other things. --NS 2006-08-16 + (and (or (and (not car-match) car-win) + (and (not cdr-match) cdr-win)) + (not (and (cons-type-might-be-empty-type type1) + (cons-type-might-be-empty-type type2)))))))))) + +(define-type-method (cons :simple-subtypep) (type1 type2) + (declare (type cons-type type1 type2)) + (multiple-value-bind (val-car win-car) + (csubtypep (cons-type-car-type type1) (cons-type-car-type type2)) + (multiple-value-bind (val-cdr win-cdr) + (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2)) + (if (and val-car val-cdr) + (values t (and win-car win-cdr)) + (values nil (or (and (not val-car) win-car) + (and (not val-cdr) win-cdr))))))) + +;;; Give up if a precise type is not possible, to avoid returning +;;; overly general types. +(define-type-method (cons :simple-union2) (type1 type2) + (declare (type cons-type type1 type2)) + (let ((car-type1 (cons-type-car-type type1)) + (car-type2 (cons-type-car-type type2)) + (cdr-type1 (cons-type-cdr-type type1)) + (cdr-type2 (cons-type-cdr-type type2)) + car-not1 + car-not2) + ;; UGH. -- CSR, 2003-02-24 + (macrolet ((frob-car (car1 car2 cdr1 cdr2 &optional not1) + `(let ((intersection (type-intersection ,car2 + ,(or not1 `(type-negation ,car1))))) + (unless (type= intersection ,car2) + (type-union + (make-cons-type ,car1 (type-union ,cdr1 ,cdr2)) + (make-cons-type intersection ,cdr2)))))) + (cond ((type= car-type1 car-type2) + (make-cons-type car-type1 + (type-union cdr-type1 cdr-type2))) + ((type= cdr-type1 cdr-type2) + (make-cons-type (type-union car-type1 car-type2) + cdr-type1)) + ;; (or (cons A1 D1) (cons A2 D2)) + ;; + ;; if A1 is a subtype of A2, this is equivalent to + ;; + ;; (or (cons A1 (or D1 D2)) (cons (and A2 (not A1)) D2)) + ((csubtypep car-type1 car-type2) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) + ((csubtypep car-type2 car-type1) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) + ;; in general + ;; + ;; (or (cons A1 D1) (cons A2 D2)) + ;; + ;; is + ;; + ;; (or (cons (and A1 A2) (or D1 D2)) + ;; (cons (and A1 (not A2)) D1) + ;; (cons (and (not A1) A2) D2)) + ;; + ;; (or (cons (integer 0 8) (integer 5 15)) + ;; (cons (integer 3 15) (integer 4 14)) + ;; + ;; -> + ;; + ;; (or (cons (integer 3 8) (integer 4 15)) + ;; (cons (integer 0 2) (integer 5 15)) + ;; (cons (integer 9 15) (integer 4 14)) + ;; + ;; if A1 and A2 are disjoint no further simplification is + ;; possible. However, if they are not disjoint, and we + ;; can tell that they are not disjoint, we should be able + ;; to break the type up into smaller pieces. + ((multiple-value-bind (yes win) + (csubtypep car-type2 (setf car-not1 (type-negation car-type1))) + (and (not yes) win)) + (let ((cdr-union (type-union cdr-type1 cdr-type2))) + (setf car-not2 (type-negation car-type2)) + (type-union + (make-cons-type (type-intersection car-type1 car-type2) cdr-union) + (make-cons-type (type-intersection car-type1 car-not2) cdr-type1) + (make-cons-type (type-intersection car-not1 car-type2) cdr-type2)))) + ((multiple-value-bind (yes win) + (csubtypep car-type1 (setf car-not2 (type-negation car-type2))) + (and (not yes) win)) + (let ((cdr-union (type-union cdr-type1 cdr-type2))) + (type-union + (make-cons-type (type-intersection car-type1 car-type2) cdr-union) + (make-cons-type (type-intersection car-type1 car-not2) cdr-type1) + (make-cons-type (type-intersection car-not1 car-type2) cdr-type2)))) + ;; Don't put these in -- consider the effect of taking the + ;; union of (CONS (INTEGER 0 2) (INTEGER 5 7)) and + ;; (CONS (INTEGER 0 3) (INTEGER 5 6)). + #+nil + ((csubtypep cdr-type1 cdr-type2) + (frob-cdr car-type1 car-type2 cdr-type1 cdr-type2)) + #+nil + ((csubtypep cdr-type2 cdr-type1) + (frob-cdr car-type2 car-type1 cdr-type2 cdr-type1)))))) + +(define-type-method (cons :simple-intersection2) (type1 type2) + (declare (type cons-type type1 type2)) + (let ((car-int2 (type-intersection2 (cons-type-car-type type1) + (cons-type-car-type type2))) + (cdr-int2 (type-intersection2 (cons-type-cdr-type type1) + (cons-type-cdr-type type2)))) + (cond + ((and car-int2 cdr-int2) (make-cons-type car-int2 cdr-int2)) + (car-int2 (make-cons-type car-int2 + (type-intersection + (cons-type-cdr-type type1) + (cons-type-cdr-type type2)))) + (cdr-int2 (make-cons-type + (type-intersection (cons-type-car-type type1) + (cons-type-car-type type2)) + cdr-int2))))) + +(!define-superclasses cons ((cons)) !cold-init-forms) + +;;;; CHARACTER-SET types + +(def-type-translator character-set + (&optional (pairs `((0 . ,(1- char-code-limit))))) + (make-character-set-type pairs)) + +(define-type-method (character-set :negate) (type) + (let ((pairs (character-set-type-pairs type))) + (if (and (= (length pairs) 1) + (= (caar pairs) 0) + (= (cdar pairs) (1- char-code-limit))) + (make-negation-type type) + (let ((not-character + (make-negation-type + (make-character-set-type + `((0 . ,(1- char-code-limit))))))) + (type-union + not-character + (make-character-set-type + (let (not-pairs) + (when (> (caar pairs) 0) + (push (cons 0 (1- (caar pairs))) not-pairs)) + (do* ((tail pairs (cdr tail)) + (high1 (cdar tail) (cdar tail)) + (low2 (caadr tail) (caadr tail))) + ((null (cdr tail)) + (when (< (cdar tail) (1- char-code-limit)) + (push (cons (1+ (cdar tail)) + (1- char-code-limit)) + not-pairs)) + (nreverse not-pairs)) + (push (cons (1+ high1) (1- low2)) not-pairs))))))))) + +(define-type-method (character-set :unparse) (type) + (cond + ((eq type (specifier-type 'character)) 'character) + ((eq type (specifier-type 'base-char)) 'base-char) + ((eq type (specifier-type 'extended-char)) 'extended-char) + ;; standard-char is not an interned type + ((type= type (specifier-type 'standard-char)) 'standard-char) + (t + ;; Unparse into either MEMBER or CHARACTER-SET. We use MEMBER if there + ;; are at most as many characters as there are character code ranges. + ;; (basically saying to use MEMBER if each range is one character) + (let* ((pairs (character-set-type-pairs type)) + (count (length pairs)) + (chars (loop named outer + for (low . high) in pairs + nconc (loop for code from low upto high + collect (code-char code) + when (minusp (decf count)) + do (return-from outer t))))) + (if (eq chars t) + `(character-set ,pairs) + `(member ,@chars)))))) + +(define-type-method (character-set :singleton-p) (type) + (let* ((pairs (character-set-type-pairs type)) + (pair (first pairs))) + (if (and (typep pairs '(cons t null)) + (eql (car pair) (cdr pair))) + (values t (code-char (car pair))) + (values nil nil)))) + +(define-type-method (character-set :simple-=) (type1 type2) + (let ((pairs1 (character-set-type-pairs type1)) + (pairs2 (character-set-type-pairs type2))) + (values (equal pairs1 pairs2) t))) + +(define-type-method (character-set :simple-subtypep) (type1 type2) + (values + (dolist (pair (character-set-type-pairs type1) t) + (unless (position pair (character-set-type-pairs type2) + :test (lambda (x y) (and (>= (car x) (car y)) + (<= (cdr x) (cdr y))))) + (return nil))) + t)) + +(define-type-method (character-set :simple-union2) (type1 type2) + ;; KLUDGE: the canonizing in the MAKE-CHARACTER-SET-TYPE function + ;; actually does the union for us. It might be a little fragile to + ;; rely on it. + (make-character-set-type + (merge 'list + (copy-alist (character-set-type-pairs type1)) + (copy-alist (character-set-type-pairs type2)) + #'< :key #'car))) + +(define-type-method (character-set :simple-intersection2) (type1 type2) + ;; KLUDGE: brute force. +#| + (let (pairs) + (dolist (pair1 (character-set-type-pairs type1) + (make-character-set-type + (sort pairs #'< :key #'car))) + (dolist (pair2 (character-set-type-pairs type2)) + (cond + ((<= (car pair1) (car pair2) (cdr pair1)) + (push (cons (car pair2) (min (cdr pair1) (cdr pair2))) pairs)) + ((<= (car pair2) (car pair1) (cdr pair2)) + (push (cons (car pair1) (min (cdr pair1) (cdr pair2))) pairs)))))) +|# + (make-character-set-type + (intersect-type-pairs + (character-set-type-pairs type1) + (character-set-type-pairs type2)))) + +;;; +;;; Intersect two ordered lists of pairs +;;; Each list is of the form ((start1 . end1) ... (startn . endn)), +;;; where start1 <= end1 < start2 <= end2 < ... < startn <= endn. +;;; Each pair represents the integer interval start..end. +;;; +(defun intersect-type-pairs (alist1 alist2) + (if (and alist1 alist2) + (let ((res nil) + (pair1 (pop alist1)) + (pair2 (pop alist2))) + (loop + (when (> (car pair1) (car pair2)) + (rotatef pair1 pair2) + (rotatef alist1 alist2)) + (let ((pair1-cdr (cdr pair1))) + (cond + ((> (car pair2) pair1-cdr) + ;; No over lap -- discard pair1 + (unless alist1 (return)) + (setq pair1 (pop alist1))) + ((<= (cdr pair2) pair1-cdr) + (push (cons (car pair2) (cdr pair2)) res) + (cond + ((= (cdr pair2) pair1-cdr) + (unless alist1 (return)) + (unless alist2 (return)) + (setq pair1 (pop alist1) + pair2 (pop alist2))) + (t ;; (< (cdr pair2) pair1-cdr) + (unless alist2 (return)) + (setq pair1 (cons (1+ (cdr pair2)) pair1-cdr)) + (setq pair2 (pop alist2))))) + (t ;; (> (cdr pair2) (cdr pair1)) + (push (cons (car pair2) pair1-cdr) res) + (unless alist1 (return)) + (setq pair2 (cons (1+ pair1-cdr) (cdr pair2))) + (setq pair1 (pop alist1)))))) + (nreverse res)) + nil)) + + +;;; Return the type that describes all objects that are in X but not +;;; in Y. +(defun type-difference (x y) + (type-intersection x (type-negation y))) + +(def-type-translator array ((:context context) + &optional (element-type '*) + (dimensions '*)) + (let ((eltype (if (eq element-type '*) + *wild-type* + (specifier-type element-type context)))) + (make-array-type (canonical-array-dimensions dimensions) + :complexp :maybe + :element-type eltype + :specialized-element-type (%upgraded-array-element-type + eltype)))) + +(def-type-translator simple-array ((:context context) + &optional (element-type '*) + (dimensions '*)) + (let ((eltype (if (eq element-type '*) + *wild-type* + (specifier-type element-type context)))) + (make-array-type (canonical-array-dimensions dimensions) + :complexp nil + :element-type eltype + :specialized-element-type (%upgraded-array-element-type + eltype)))) + +;;;; SIMD-PACK types + +#+sb-simd-pack +(defun make-simd-pack-type (element-type) + (aver (neq element-type *wild-type*)) + (if (eq element-type *empty-type*) + *empty-type* + (%make-simd-pack-type + (dolist (pack-type *simd-pack-element-types* + (error "~S element type must be a subtype of ~ + ~{~/sb-impl:print-type-specifier/~#[~;, or ~ + ~:;, ~]~}." + 'simd-pack *simd-pack-element-types*)) + (when (csubtypep element-type (specifier-type pack-type)) + (return (list pack-type))))))) + +#+sb-simd-pack-256 +(defun make-simd-pack-256-type (element-type) + (aver (neq element-type *wild-type*)) + (if (eq element-type *empty-type*) + *empty-type* + (%make-simd-pack-256-type + (dolist (pack-type *simd-pack-element-types* + (error "~S element type must be a subtype of ~ + ~{~/sb-impl:print-type-specifier/~#[~;, or ~ + ~:;, ~]~}." + 'simd-pack-256 *simd-pack-element-types*)) + (when (csubtypep element-type (specifier-type pack-type)) + (return (list pack-type))))))) + +#+sb-simd-pack +(progn + (define-type-class simd-pack :enumerable nil + :might-contain-other-types nil) + + ;; Though this involves a recursive call to parser, parsing context need not + ;; be passed down, because an unknown-type condition is an immediate failure. + (def-type-translator simd-pack (&optional (element-type-spec '*)) + (if (eql element-type-spec '*) + (%make-simd-pack-type *simd-pack-element-types*) + (make-simd-pack-type (single-value-specifier-type element-type-spec)))) + + (define-type-method (simd-pack :negate) (type) + (let ((remaining (set-difference *simd-pack-element-types* + (simd-pack-type-element-type type))) + (not-simd-pack (make-negation-type (specifier-type 'simd-pack)))) + (if remaining + (type-union not-simd-pack (%make-simd-pack-type remaining)) + not-simd-pack))) + + (define-type-method (simd-pack :unparse) (type) + (let ((eltypes (simd-pack-type-element-type type))) + (cond ((equal eltypes *simd-pack-element-types*) + 'simd-pack) + ((= 1 (length eltypes)) + `(simd-pack ,(first eltypes))) + (t + `(or ,@(mapcar (lambda (eltype) + `(simd-pack ,eltype)) + eltypes)))))) + + (define-type-method (simd-pack :simple-=) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (values + (null (set-exclusive-or (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2))) + t)) + + (define-type-method (simd-pack :simple-subtypep) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (subsetp (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2))) + + (define-type-method (simd-pack :simple-union2) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (%make-simd-pack-type (union (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + + (define-type-method (simd-pack :simple-intersection2) (type1 type2) + (declare (type simd-pack-type type1 type2)) + (let ((intersection (intersection (simd-pack-type-element-type type1) + (simd-pack-type-element-type type2)))) + (if intersection + (%make-simd-pack-type intersection) + *empty-type*))) + + (!define-superclasses simd-pack ((simd-pack)) !cold-init-forms)) + +#+sb-simd-pack-256 +(progn + (define-type-class simd-pack-256 :enumerable nil + :might-contain-other-types nil) + + ;; Though this involves a recursive call to parser, parsing context need not + ;; be passed down, because an unknown-type condition is an immediate failure. + (def-type-translator simd-pack-256 (&optional (element-type-spec '*)) + (if (eql element-type-spec '*) + (%make-simd-pack-256-type *simd-pack-element-types*) + (make-simd-pack-256-type (single-value-specifier-type element-type-spec)))) + + (define-type-method (simd-pack-256 :negate) (type) + (let ((remaining (set-difference *simd-pack-element-types* + (simd-pack-256-type-element-type type))) + (not-simd-pack-256 (make-negation-type (specifier-type 'simd-pack-256)))) + (if remaining + (type-union not-simd-pack-256 (%make-simd-pack-256-type remaining)) + not-simd-pack-256))) + + (define-type-method (simd-pack-256 :unparse) (type) + (let ((eltypes (simd-pack-256-type-element-type type))) + (cond ((equal eltypes *simd-pack-element-types*) + 'simd-pack-256) + ((= 1 (length eltypes)) + `(simd-pack-256 ,(first eltypes))) + (t + `(or ,@(mapcar (lambda (eltype) + `(simd-pack-256 ,eltype)) + eltypes)))))) + + (define-type-method (simd-pack-256 :simple-=) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (values + (null (set-exclusive-or (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2))) + t)) + + (define-type-method (simd-pack-256 :simple-subtypep) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (subsetp (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2))) + + (define-type-method (simd-pack-256 :simple-union2) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (%make-simd-pack-256-type (union (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2)))) + + (define-type-method (simd-pack-256 :simple-intersection2) (type1 type2) + (declare (type simd-pack-256-type type1 type2)) + (let ((intersection (intersection (simd-pack-256-type-element-type type1) + (simd-pack-256-type-element-type type2)))) + (if intersection + (%make-simd-pack-256-type intersection) + *empty-type*))) + + (!define-superclasses simd-pack-256 ((simd-pack-256)) !cold-init-forms)) + +;;;; utilities shared between cross-compiler and target system + +;;; Does the type derived from compilation of an actual function +;;; definition satisfy declarations of a function's type? +(defun defined-ftype-matches-declared-ftype-p (defined-ftype declared-ftype) + (declare (type ctype defined-ftype declared-ftype)) + (flet ((is-built-in-class-function-p (ctype) + (and (built-in-classoid-p ctype) + (eq (built-in-classoid-name ctype) 'function)))) + (cond (;; DECLARED-FTYPE could certainly be #; + ;; that's what happens when we (DECLAIM (FTYPE FUNCTION FOO)). + (is-built-in-class-function-p declared-ftype) + ;; In that case, any definition satisfies the declaration. + t) + (;; It's not clear whether or how DEFINED-FTYPE might be + ;; #, but it's not obviously + ;; invalid, so let's handle that case too, just in case. + (is-built-in-class-function-p defined-ftype) + ;; No matter what DECLARED-FTYPE might be, we can't prove + ;; that an object of type FUNCTION doesn't satisfy it, so + ;; we return success no matter what. + t) + (;; Otherwise both of them must be FUN-TYPE objects. + t + ;; FIXME: For now we only check compatibility of the return + ;; type, not argument types, and we don't even check the + ;; return type very precisely (as per bug 94a). It would be + ;; good to do a better job. Perhaps to check the + ;; compatibility of the arguments, we should (1) redo + ;; VALUES-TYPES-EQUAL-OR-INTERSECT as + ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to + ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE + ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) + (values-types-equal-or-intersect + (fun-type-returns defined-ftype) + (fun-type-returns declared-ftype)))))) + +;;; This messy case of CTYPE for NUMBER is shared between the +;;; cross-compiler and the target system. +;;; I'm not sure whether NaNs should be numeric types versus MEMBER (like +;;; sigleton signed zero without the "other" sign), but it may not matter. +;;; At a bare minimum this prevents crashing in min/max. +(defun ctype-of-number (x) + (let ((num (if (complexp x) (realpart x) x))) + (multiple-value-bind (complexp low high) + (cond ((complexp x) + (let ((imag (imagpart x))) + (if (and (floatp num) (or (float-nan-p num) (float-nan-p imag))) + (values :complex nil nil) + (values :complex (sb-xc:min num imag) (sb-xc:max num imag))))) + ((and (floatp num) (float-nan-p num)) + (values :real nil nil)) + (t + (values :real num num))) + (make-numeric-type :class (etypecase num + (integer (if (complexp x) + (if (integerp (imagpart x)) + 'integer + 'rational) + 'integer)) + (rational 'rational) + (float 'float)) + :format (and (floatp num) (float-format-name num)) + :complexp complexp + :low low + :high high)))) + +;;; The following function is a generic driver for approximating +;;; set-valued functions over types. Putting this here because it'll +;;; probably be useful for a lot of type analyses. +;;; +;;; Let f be a function from values of type X to Y, e.g., ARRAY-RANK. +;;; +;;; We compute an over or under-approximation of the set +;;; +;;; F(TYPE) = { f(x) : x in TYPE /\ x in X } \subseteq Y +;;; +;;; via set-valued approximations of f, OVER and UNDER. +;;; +;;; These functions must have the property that +;;; Forall TYPE, OVER(TYPE) \superseteq F(TYPE) and +;;; Forall TYPE, UNDER(TYPE) \subseteq F(TYPE) +;;; +;;; The driver is also parameterised over the finite set +;;; representation. +;;; +;;; Union, intersection and difference are binary functions to compute +;;; set union, intersection and difference. Top and bottom are the +;;; concrete representations for the universe and empty sets; we never +;;; call the set functions on top or bottom, so it's safe to use +;;; special values there. +;;; +;;; Arguments: +;;; +;;; TYPE: the ctype for which we wish to approximate F(TYPE) +;;; OVERAPPROXIMATE: true if we wish to overapproximate, nil otherwise. +;;; You usually want T. +;;; UNION/INTERSECTION/DIFFERENCE: implementations of finite set operations. +;;; Conform to cl::(union/intersection/set-difference). Passing NIL will +;;; disable some cleverness and result in quicker computation of coarser +;;; approximations. However, passing difference without union and intersection +;;; will probably not end well. +;;; TOP/BOTTOM: concrete representation of the universe and empty set. Finite +;;; set operations are never called on TOP/BOTTOM, so it's safe to use special +;;; values there. +;;; OVER/UNDER: the set-valued approximations of F. +;;; +;;; Implementation details. +;;; +;;; It's a straightforward walk down the type. +;;; Union types -> take the union of children, intersection -> +;;; intersect. There is some complication for negation types: we must +;;; not only negate the result, but also flip from overapproximating +;;; to underapproximating in the children (or vice versa). +;;; +;;; We represent sets as a pair of (negate-p finite-set) in order to +;;; support negation types. + +(declaim (maybe-inline generic-abstract-type-function)) +(defun generic-abstract-type-function + (type overapproximate + union intersection difference + top bottom + over under) + (labels ((union* (x y) + ;; wrappers to avoid calling union/intersection on + ;; top/bottom. + (cond ((or (eql x top) + (eql y top)) + top) + ((eql x bottom) y) + ((eql y bottom) x) + (t + (funcall union x y)))) + (intersection* (x y) + (cond ((or (eql x bottom) + (eql y bottom)) + bottom) + ((eql x top) y) + ((eql y top) x) + (t + (funcall intersection x y)))) + (unite (not-x-p x not-y-p y) + ;; if we only have one negated set, it's x. + (when not-y-p + (rotatef not-x-p not-y-p) + (rotatef x y)) + (cond ((and not-x-p not-y-p) + ;; -x \/ -y = -(x /\ y) + (normalize t (intersection* x y))) + (not-x-p + ;; -x \/ y = -(x \ y) + (cond ((eql x top) + (values nil y)) + ((or (eql y top) + (eql x bottom)) + (values nil top)) + ((eql y bottom) + (values t x)) + (t + (normalize t + (funcall difference x y))))) + (t + (values nil (union* x y))))) + (intersect (not-x-p x not-y-p y) + (when not-y-p + (rotatef not-x-p not-y-p) + (rotatef x y)) + (cond ((and not-x-p not-y-p) + ;; -x /\ -y = -(x \/ y) + (normalize t (union* x y))) + (not-x-p + ;; -x /\ y = y \ x + (cond ((or (eql x top) (eql y bottom)) + (values nil bottom)) + ((eql x bottom) + (values nil y)) + ((eql y top) + (values t x)) + (t + (values nil (funcall difference y x))))) + (t + (values nil (intersection* x y))))) + (normalize (not-x-p x) + ;; catch some easy cases of redundant negation. + (cond ((not not-x-p) + (values nil x)) + ((eql x top) + bottom) + ((eql x bottom) + top) + (t + (values t x)))) + (default (overapproximate) + ;; default value + (if overapproximate top bottom)) + (walk-union (types overapproximate) + ;; Only do this if union is provided. + (unless union + (return-from walk-union (default overapproximate))) + ;; Reduce/union from bottom. + (let ((not-acc-p nil) + (acc bottom)) + (dolist (type types (values not-acc-p acc)) + (multiple-value-bind (not x) + (walk type overapproximate) + (setf (values not-acc-p acc) + (unite not-acc-p acc not x))) + ;; Early exit on top set. + (when (and (eql acc top) + (not not-acc-p)) + (return (values nil top)))))) + (walk-intersection (types overapproximate) + ;; Skip if we don't know how to intersect sets + (unless intersection + (return-from walk-intersection (default overapproximate))) + ;; Reduce/intersection from top + (let ((not-acc-p nil) + (acc top)) + (dolist (type types (values not-acc-p acc)) + (multiple-value-bind (not x) + (walk type overapproximate) + (setf (values not-acc-p acc) + (intersect not-acc-p acc not x))) + (when (and (eql acc bottom) + (not not-acc-p)) + (return (values nil bottom)))))) + (walk-negate (type overapproximate) + ;; Don't introduce negated types if we don't know how to + ;; subtract sets. + (unless difference + (return-from walk-negate (default overapproximate))) + (multiple-value-bind (not x) + (walk type (not overapproximate)) + (normalize (not not) x))) + (walk (type overapproximate) + (typecase type + (union-type + (walk-union (union-type-types type) overapproximate)) + ((cons (member or union)) + (walk-union (rest type) overapproximate)) + (intersection-type + (walk-intersection (intersection-type-types type) overapproximate)) + ((cons (member and intersection)) + (walk-intersection (rest type) overapproximate)) + (negation-type + (walk-negate (negation-type-type type) overapproximate)) + ((cons (eql not)) + (walk-negate (second type) overapproximate)) + (t + (values nil + (if overapproximate + (if over + (funcall over type) + (default t)) + (if under + (funcall under type) + (default nil)))))))) + (multiple-value-call #'normalize (walk type overapproximate)))) + +;;; Standard list representation of sets. Use CL:* for the universe. +(defun list-abstract-type-function (type over &key under (overapproximate t)) + #-sb-xc-host (declare (inline generic-abstract-type-function)) + (generic-abstract-type-function + type overapproximate + #'union #'intersection #'set-difference + '* nil + over under)) + +(!defun-from-collected-cold-init-forms !type-cold-init) + +;;; This decides if two type expressions are equal ignoring the order of terms +;;; in AND and OR. It doesn't decide equivalence, but it's good enough +;;; to do some sanity checking in type.before-xc and genesis. +(defun brute-force-type-specifier-equalp (a b) + (labels ((compare (a b) + (if (symbolp a) + (eq a b) + (or (equal a b) + (and (listp b) + (eq (car a) (car b)) + (case (car a) + ((and or) + (order-insensitive-equal (cdr a) (cdr b))) + ((not) + (compare (cadr a) (cadr b)))))))) + (order-insensitive-equal (a b) + (and (= (length a) (length b)) + (every (lambda (elt) (member elt b :test #'compare)) a) + (every (lambda (elt) (member elt a :test #'compare)) b)))) + (compare a b))) diff -Nru sbcl-2.1.1/src/code/typep.lisp sbcl-2.1.11/src/code/typep.lisp --- sbcl-2.1.1/src/code/typep.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/typep.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,7 +9,7 @@ (in-package "SB-KERNEL") -#-sb-devel(declaim (start-block)) +(declaim (start-block)) ;;; (Note that when cross-compiling, SB-XC:TYPEP is interpreted as a ;;; test that the host Lisp object OBJECT translates to a target SBCL @@ -74,21 +74,19 @@ (type-specifier type)) t) (or (eq (array-type-specialized-element-type type) *wild-type*) + ;; FIXME: see whether this TYPE= can be reduced to EQ. + ;; (Each specialized element type should be an interned ctype) (values (type= (array-type-specialized-element-type type) - ;; FIXME: not the most efficient. - (specifier-type (array-element-type - object))))))) + (sb-vm::array-element-ctype object)))))) (member-type (when (member-type-member-p object type) t)) (classoid - ;; It might be more efficient to check that OBJECT is either INSTANCEP - ;; or FUNCALLABLE-INSTANCE-P before making this call. - ;; But doing that would change the behavior if %%TYPEP were ever called - ;; with a built-in classoid whose members are not instances. - ;; e.g. (%%typep (find-fdefn 'car) (specifier-type 'fdefn)) - ;; I'm not sure if that can happen. - (classoid-typep (layout-of object) type object)) + (if (built-in-classoid-p type) + (funcall (built-in-classoid-predicate type) object) + (and (or (%instancep object) + (functionp object)) + (classoid-typep (wrapper-of object) type object)))) (union-type (some (lambda (union-type-type) (recurse object union-type-type)) (union-type-types type))) @@ -135,7 +133,7 @@ ((functionp) (functionp object)) ; least strict ((nil) ; medium strict (and (functionp object) - (csubtypep (specifier-type (sb-impl::%fun-type object)) type))) + (csubtypep (specifier-type (sb-impl::%fun-ftype object)) type))) (t ; strict (error "Function types are not a legal argument to TYPEP:~% ~S" (type-specifier type)))))))) @@ -156,9 +154,8 @@ (block nil (classoid-typep (typecase object - (instance (%instance-layout object)) - (funcallable-instance - (%fun-layout object)) + (instance (%instance-wrapper object)) + (funcallable-instance (%fun-wrapper object)) (t (return))) (cdr (truly-the cons cache)) object))) @@ -180,23 +177,27 @@ (unless classoid (error "The class ~S has not yet been defined." (classoid-cell-name cell))) - (classoid-typep layout classoid object))) + (classoid-typep (layout-friend layout) classoid object))) ;;; Return true of any object which is either a funcallable-instance, ;;; or an ordinary instance that is not a structure-object. (declaim (inline %pcl-instance-p)) (defun %pcl-instance-p (x) - ;; The COND is more efficient than LAYOUT-OF. - (layout-for-pcl-obj-p (cond ((%instancep x) (%instance-layout x)) - ((function-with-layout-p x) (%fun-layout x)) - (t (return-from %pcl-instance-p nil))))) + ;; read-time eval so that vop-existsp isn't part of the inline expansion + #.(if (sb-c::vop-existsp :translate %instanceoid-layout) + '(logtest (layout-flags (%instanceoid-layout x)) +pcl-object-layout-flag+) + ;; The COND is slightly more efficient than LAYOUT-OF. + '(layout-for-pcl-obj-p + (cond ((%instancep x) (%instance-layout x)) + ((function-with-layout-p x) (%fun-layout x)) + (t (return-from %pcl-instance-p nil)))))) ;;; Try to ensure that the object's layout is up-to-date only if it is an instance ;;; or funcallable-instance of other than a static or structure classoid type. (defun update-object-layout (object) - (if (%pcl-instance-p object) - (sb-pcl::check-wrapper-validity object) - (layout-of object))) + (wrapper-friend (if (%pcl-instance-p object) + (sb-pcl::check-wrapper-validity object) + (wrapper-of object)))) ;;; Test whether OBJ-LAYOUT is from an instance of CLASSOID. @@ -228,6 +229,7 @@ ;;; of thousands of iterations of 'classoid-typep.impure.lisp' (defun classoid-typep (obj-layout classoid object) + (declare (type wrapper obj-layout)) ;; FIXME & KLUDGE: We could like to grab the *WORLD-LOCK* here (to ensure that ;; class graph doesn't change while we're doing the typep test), but in ;; practice that causes trouble -- deadlocking against the compiler @@ -242,24 +244,24 @@ ;; that we're testing against. Whether obj-layout is "valid" has no relevance. ;; This is racy though because %ENSURE-CLASSOID-VALID should return ;; the most up-to-date layout for the classoid, but it doesn't. Oh well. - (%ensure-classoid-valid classoid (classoid-layout classoid) "typep") - (values obj-layout (classoid-layout classoid))) + (%ensure-classoid-valid classoid (classoid-wrapper classoid) "typep") + (values obj-layout (classoid-wrapper classoid))) (t ;; And this case is even more racy, naturally. - (do ((layout (classoid-layout classoid) (classoid-layout classoid)) + (do ((layout (classoid-wrapper classoid) (classoid-wrapper classoid)) (i 0 (+ i 1)) (obj-layout obj-layout)) - ((and (not (layout-invalid obj-layout)) - (not (layout-invalid layout))) + ((and (not (wrapper-invalid obj-layout)) + (not (wrapper-invalid layout))) (values obj-layout layout)) (aver (< i 2)) (%ensure-classoid-valid classoid layout "typep") - (when (zerop (layout-clos-hash obj-layout)) + (when (zerop (wrapper-clos-hash obj-layout)) (setq obj-layout (sb-pcl::check-wrapper-validity object)))))) ;; FIXME: if LAYOUT is for a structure, use the STRUCTURE-IS-A test ;; which avoids iterating. (or (eq obj-layout layout) - (let ((obj-inherits (layout-inherits obj-layout))) + (let ((obj-inherits (wrapper-inherits obj-layout))) (dotimes (i (length obj-inherits) nil) (when (eq (svref obj-inherits i) layout) (return t))))))) @@ -292,11 +294,14 @@ (values (%%typep obj type) t))) (classoid (if (built-in-classoid-p type) - (values (%%typep obj type) t) + (values (funcall (built-in-classoid-predicate type) obj) t) + ;; Hmm, if the classoid is a subtype of STRUCTURE-OBJECT, + ;; can we not decide this _now_ ? In fact, even for STANDARD-OBJECT, the spec + ;; says the compiler may assume inheritance not to change at runtime. (if (if (csubtypep type (specifier-type 'function)) (funcallable-instance-p obj) (%instancep obj)) - (if (eq (classoid-layout type) + (if (eq (classoid-wrapper type) (info :type :compiler-layout (classoid-name type))) (values (sb-xc:typep obj type) t) (values nil nil)) @@ -382,7 +387,7 @@ (function (if (funcallable-instance-p x) (classoid-of x) - (let ((type (sb-impl::%fun-type x))) + (let ((type (sb-impl::%fun-ftype x))) (if (typep type '(cons (eql function))) ; sanity test (try-cache type) (classoid-of x))))) @@ -455,7 +460,7 @@ sb-vm:n-widetag-bits) (array-underlying-widetag array))))) ;; The value computed on cache miss. - (let ((etype (specifier-type (array-element-type array)))) + (let ((etype (sb-vm::array-element-ctype array))) (make-array-type (array-dimensions array) :complexp (not (simple-array-p array)) :element-type etype diff -Nru sbcl-2.1.1/src/code/unix.lisp sbcl-2.1.11/src/code/unix.lisp --- sbcl-2.1.1/src/code/unix.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/unix.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -67,6 +67,7 @@ "sb_select" ; int-syscall "sb_getitimer" ; syscall* "sb_setitimer" ; syscall* + "sb_clock_gettime" ; alien-funcall "sb_utimes") ; posix :test #'string=) (subseq x 3) @@ -178,11 +179,13 @@ #+win32 (sb-win32:unixlike-open path flags :overlapped overlapped) #-win32 (with-restarted-syscall (value errno) - (int-syscall ("open" c-string int int) - path - (logior #+largefile o_largefile - flags) - mode))) + (locally + (declare (optimize (sb-c::float-accuracy 0))) + (let ((result (alien-funcall (extern-alien "open" (function int c-string int &optional int)) + path (logior flags) mode))) + (if (minusp result) + (values nil (get-errno)) + (values result 0)))))) ;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file ;;; associated with it. @@ -1049,7 +1052,8 @@ (defun clock-gettime (clockid) (declare (type (signed-byte 32) clockid)) (with-alien ((ts (struct timespec))) - (alien-funcall (extern-alien "clock_gettime" (function int int (* (struct timespec)))) + (alien-funcall (extern-alien #.(libc-name-for "sb_clock_gettime") + (function int int (* (struct timespec)))) clockid (addr ts)) ;; 'seconds' is definitely a fixnum for 64-bit, because most-positive-fixnum ;; can express 1E11 years in seconds. diff -Nru sbcl-2.1.1/src/code/warm-error.lisp sbcl-2.1.11/src/code/warm-error.lisp --- sbcl-2.1.1/src/code/warm-error.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/warm-error.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -44,7 +44,7 @@ (superclassoid-name (classoid-name super))) ;; CONDITION is necessarily an INSTANCE, ;; but pedantry requires it be the right subtype of instance. - (unless (classoid-typep (%instance-layout condition) + (unless (classoid-typep (%instance-wrapper condition) super condition) (error 'simple-type-error :datum datum :expected-type superclassoid-name diff -Nru sbcl-2.1.1/src/code/warm-mswin.lisp sbcl-2.1.11/src/code/warm-mswin.lisp --- sbcl-2.1.1/src/code/warm-mswin.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/warm-mswin.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -83,6 +83,10 @@ (process handle) (exit-code uint)) +(defun zero-alien (alien type) + `(alien-funcall (extern-alien "memset" (function void system-area-pointer int unsigned)) + (alien-sap ,alien) 0 (alien-size ,type :bytes))) + (defun mswin-spawn (program argv stdin stdout stderr searchp envp directory window preserve-handles) (let ((std-handles (multiple-value-list (get-std-handles))) (inheritp nil)) @@ -95,9 +99,7 @@ do (setf (inheritable-handle-p handle) t))) (with-alien ((process-information process-information) (startup-info startup-info)) - (sb-kernel:system-area-ub8-fill - 0 (alien-sap startup-info) - 0 (alien-size startup-info :bytes)) + (zero-alien startup-info startup-info) (setf (slot startup-info 'cb) (alien-size startup-info :bytes) (slot startup-info 'stdin) (maybe-std-handle stdin) (slot startup-info 'stdout) (maybe-std-handle stdout) @@ -270,11 +272,6 @@ (defconstant +copier-buffer+ 256) -(defmacro zero-alien (alien type) - `(sb-kernel:system-area-ub8-fill - 0 (alien-sap ,alien) - 0 (alien-size ,type :bytes))) - (defun setup-copiers (copiers) (let ((result (make-array (length copiers)))) (loop for copier in copiers diff -Nru sbcl-2.1.1/src/code/win32.lisp sbcl-2.1.11/src/code/win32.lisp --- sbcl-2.1.1/src/code/win32.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/win32.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -128,7 +128,9 @@ (nevents (* dword))) (define-alien-routine "socket_input_available" int - (socket handle)) + (socket handle) + (time long) + (utime long)) (define-alien-routine "console_handle_p" boolean (handle handle)) @@ -139,7 +141,7 @@ ;;; introspect it, so we have to try various things until we find ;;; something that works. Returns true if there could be input ;;; available, or false if there is not. -(defun handle-listen (handle) +(defun handle-listen (handle &optional (time 0) (utime 0)) (cond ((console-handle-p handle) (alien-funcall (extern-alien "win32_tty_listen" (function boolean handle)) @@ -151,7 +153,7 @@ (cond ((not (zerop res)) (return-from handle-listen (plusp avail))) ((= code error-broken-pipe) (return-from handle-listen t))))) - (let ((res (socket-input-available handle))) + (let ((res (socket-input-available handle time utime))) (unless (zerop res) (return-from handle-listen (= res 1)))) t))) diff -Nru sbcl-2.1.1/src/code/x86-64-vm.lisp sbcl-2.1.11/src/code/x86-64-vm.lisp --- sbcl-2.1.1/src/code/x86-64-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/code/x86-64-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -39,7 +39,49 @@ (sap-ref-single sap 4))) (complex-double-float (complex (sap-ref-double sap 0) - (sap-ref-double sap 8)))))) + (sap-ref-double sap 8))) + #+sb-simd-pack + (simd-pack-int + (%make-simd-pack-ub64 + (sap-ref-64 sap 0) + (sap-ref-64 sap 8))) + #+sb-simd-pack + (simd-pack-single + (%make-simd-pack-single + (sap-ref-single sap 0) + (sap-ref-single sap 4) + (sap-ref-single sap 8) + (sap-ref-single sap 12))) + #+sb-simd-pack + (simd-pack-double + (%make-simd-pack-double + (sap-ref-double sap 0) + (sap-ref-double sap 8))) + #+sb-simd-pack-256 + (simd-pack-256-int + (%make-simd-pack-256-ub64 + (sap-ref-64 sap 0) + (sap-ref-64 sap 8) + (sap-ref-64 sap 16) + (sap-ref-64 sap 24))) + #+sb-simd-pack-256 + (simd-pack-256-single + (%make-simd-pack-256-single + (sap-ref-single sap 0) + (sap-ref-single sap 4) + (sap-ref-single sap 8) + (sap-ref-single sap 12) + (sap-ref-single sap 16) + (sap-ref-single sap 20) + (sap-ref-single sap 24) + (sap-ref-single sap 28))) + #+sb-simd-pack-256 + (simd-pack-256-double + (%make-simd-pack-256-double + (sap-ref-double sap 0) + (sap-ref-double sap 8) + (sap-ref-double sap 16) + (sap-ref-double sap 24)))))) (defun %set-context-float-register (context index format value) (declare (ignorable context index format)) @@ -63,7 +105,49 @@ (locally (declare (type (complex double-float) value)) (setf (sap-ref-double sap 0) (realpart value) - (sap-ref-double sap 8) (imagpart value))))))) + (sap-ref-double sap 8) (imagpart value)))) + #+sb-simd-pack + (simd-pack-int + (multiple-value-bind (a b) (%simd-pack-ub64s value) + (setf (sap-ref-64 sap 0) a + (sap-ref-64 sap 8) b))) + #+sb-simd-pack + (simd-pack-single + (multiple-value-bind (a b c d) (%simd-pack-singles value) + (setf (sap-ref-single sap 0) a + (sap-ref-single sap 4) b + (sap-ref-single sap 8) c + (sap-ref-single sap 12) d))) + #+sb-simd-pack + (simd-pack-double + (multiple-value-bind (a b) (%simd-pack-doubles value) + (setf (sap-ref-double sap 0) a + (sap-ref-double sap 8) b))) + #+sb-simd-pack-256 + (simd-pack-256-int + (multiple-value-bind (a b c d) (%simd-pack-256-ub64s value) + (setf (sap-ref-64 sap 0) a + (sap-ref-64 sap 8) b + (sap-ref-64 sap 16) c + (sap-ref-64 sap 24) d))) + #+sb-simd-pack-256 + (simd-pack-256-single + (multiple-value-bind (a b c d e f g h) (%simd-pack-256-singles value) + (setf (sap-ref-single sap 0) a + (sap-ref-single sap 4) b + (sap-ref-single sap 8) c + (sap-ref-single sap 12) d + (sap-ref-single sap 16) e + (sap-ref-single sap 20) f + (sap-ref-single sap 24) g + (sap-ref-single sap 28) h))) + #+sb-simd-pack-256 + (simd-pack-256-double + (multiple-value-bind (a b c d) (%simd-pack-256-doubles value) + (setf (sap-ref-double sap 0) a + (sap-ref-double sap 8) b + (sap-ref-double sap 16) c + (sap-ref-double sap 24) d)))))) ;;; Given a signal context, return the floating point modes word in ;;; the same format as returned by FLOATING-POINT-MODES. @@ -106,16 +190,21 @@ (let* ((data (sap-ref-8 pc 1)) ; encodes dst register and size (value (sb-vm:context-register context (ash data -2))) (nbytes (ash 1 (logand data #b11))) - ;; EMIT-SAP-REF always loads the EA into TEMP-REG-TN - ;; which points to the shadow, not the user memory now. - (ea (logxor (sb-vm:context-register - context (tn-offset sb-vm::temp-reg-tn)) + ;; EMIT-SAP-REF wires the EA to a predetermined register, + ;; which now points to the shadow space, not the user memory. + (ea (logxor (sb-vm:context-register context msan-temp-reg-number) msan-mem-to-shadow-xor-const))) `(:raw ,ea ,nbytes ,value))))) (t (sb-kernel::decode-internal-error-args (sap+ pc 1) trap-number))))) +#+immobile-space +(defun alloc-immobile-fdefn () + (alloc-immobile-fixedobj fdefn-size + (logior (ash undefined-fdefn-header 16) + fdefn-widetag))) ; word 0 + #+immobile-code (progn (defconstant trampoline-entry-offset n-word-bytes) @@ -137,7 +226,7 @@ ;; in arch_write_linkage_table_entry() and arch_do_displaced_inst(). (setf (sap-ref-32 sap 0) #x058B48 ; REX MOV [RIP-n] (signed-sap-ref-32 sap 3) (- ea (+ (sap-int sap) 7))) ; disp - (let ((i (if (/= (fun-subtype fun) funcallable-instance-widetag) + (let ((i (if (/= (%fun-pointer-widetag fun) funcallable-instance-widetag) 7 (let ((disp8 (- (ash funcallable-instance-function-slot word-shift) @@ -157,12 +246,11 @@ ;;; Return T if FUN can't be called without loading RAX with its descriptor. ;;; This is true of any funcallable instance which is not a GF, and closures. (defun fun-requires-simplifying-trampoline-p (fun) - (let ((kind (fun-subtype fun))) - (or (and (eql kind sb-vm:funcallable-instance-widetag) - ;; if the FIN has no raw words then it has no internal trampoline - (eql (layout-bitmap (%fun-layout fun)) - +layout-all-tagged+)) - (eql kind sb-vm:closure-widetag)))) + (case (%fun-pointer-widetag fun) + (#.sb-vm:closure-widetag t) + (#.sb-vm:funcallable-instance-widetag + ;; if the FIN has no raw words then it has no internal trampoline + (sb-kernel::bitmap-all-taggedp (%fun-layout fun))))) ;; TODO: put a trampoline in all fins and allocate them anywhere. ;; Revision e7cd2bd40f5b9988 caused some FINs to go in dynamic space @@ -190,16 +278,15 @@ ;; self-pointer (trampoline) slot. Scavenging the self-pointer is unnecessary ;; though harmless. This intricate and/or obfuscated calculation of #b110 ;; is insensitive to the index of the trampoline slot, probably. -#+immobile-code (defun make-immobile-funinstance (layout slot-vector) (let ((gf (truly-the funcallable-instance (alloc-immobile-fixedobj 6 ; KLUDGE (logior (ash 5 n-widetag-bits) funcallable-instance-widetag))))) ;; Assert that raw bytes will not cause GC invariant lossage - (aver (/= (layout-bitmap layout) +layout-all-tagged+)) + (aver (not (sb-kernel::bitmap-all-taggedp layout))) ;; Set layout prior to writing raw slots - (setf (%fun-layout gf) layout) + (setf (%fun-wrapper gf) layout) ;; just being pedantic - liveness is preserved by the stack reference. (with-pinned-objects (gf) (let* ((addr (logandc2 (get-lisp-obj-address gf) lowtag-mask)) @@ -209,21 +296,9 @@ (truly-the word (+ addr insts-offs)) (sap-ref-word sap insts-offs) #xFFFFFFE9058B48 ; MOV RAX,[RIP-23] (sap-ref-32 sap (+ insts-offs 7)) #x00FD60FF))) ; JMP [RAX-3] - (%set-funcallable-instance-info gf 0 slot-vector) + (setf (%funcallable-instance-info gf 0) slot-vector) gf)) -#+immobile-space -(defun alloc-immobile-fdefn () - (or #+nil ; Avoid creating new objects in the text segment for now - (and (= (alien-funcall (extern-alien "lisp_code_in_elf" (function int))) 1) - (alloc-immobile-code (* fdefn-size n-word-bytes) - (logior (ash undefined-fdefn-header 16) - fdefn-widetag) ; word 0 - 0 other-pointer-lowtag nil)) ; word 1, lowtag, errorp - (alloc-immobile-fixedobj fdefn-size - (logior (ash undefined-fdefn-header 16) - fdefn-widetag)))) ; word 0 - (defun fdefn-has-static-callers (fdefn) (declare (type fdefn fdefn)) (with-pinned-objects (fdefn) @@ -315,7 +390,16 @@ (defun alloc-dynamic-space-code (total-words) (values (%primitive alloc-dynamic-space-code (the fixnum total-words)))) -;;; Remove calls via fdefns from CODE when compiling into memory. +(define-load-time-global *never-statically-link* '(find-package)) +;;; Remove calls via fdefns from CODE. This is called after compiling +;;; to memory, or when saving a core. +;;; Do not replace globally notinline functions, because notinline has +;;; an extra connotation of ensuring that replacement of the function +;;; under that name always works. It usually works to replace a statically +;;; linked function, but with a caveat: un-statically-linking requires calling +;;; MAP-OBJECTS-IN-RANGE, which is unreliable in the presence of +;;; multiple threads. Unfortunately, some users dangerously redefine +;;; builtin functions, and moreover, while there are multiple threads. (defun statically-link-code-obj (code fixups) (declare (ignorable code fixups)) (unless (immobile-space-obj-p code) @@ -323,7 +407,7 @@ #+immobile-code (let* ((fdefns-start (+ code-constants-offset (* code-slots-per-simple-fun (code-n-entries code)))) - (fdefns-count (code-n-named-calls code)) + (fdefns-count (the index (code-n-named-calls code))) (replacements (make-array fdefns-count :initial-element nil)) (ambiguous (make-array fdefns-count :initial-element 0 :element-type 'bit)) (any-replacements) @@ -338,7 +422,9 @@ (let* ((fdefn (code-header-ref code (+ fdefns-start i))) (fun (when (fdefn-p fdefn) (fdefn-fun fdefn)))) (when (and (immobile-space-obj-p fun) - (not (fun-requires-simplifying-trampoline-p fun))) + (not (fun-requires-simplifying-trampoline-p fun)) + (not (member (fdefn-name fdefn) *never-statically-link* :test 'equal)) + (neq (info :function :inlinep (fdefn-name fdefn)) 'notinline)) (setf any-replacements t (aref replacements i) fun)))) (dotimes (i fdefns-count) (when (and (aref replacements i) diff -Nru sbcl-2.1.1/src/cold/base-target-features.lisp-expr sbcl-2.1.11/src/cold/base-target-features.lisp-expr --- sbcl-2.1.1/src/cold/base-target-features.lisp-expr 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/cold/base-target-features.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,397 @@ +;;;; -*- Lisp -*- + +;;;; tags which are set during the build process and which end up in +;;;; CL:*FEATURES* in the target SBCL, plus some comments about other +;;;; CL:*FEATURES* tags which have special meaning to SBCL or which +;;;; have a special conventional meaning +;;;; +;;;; Note that the recommended way to customize the features of a +;;;; local build of SBCL is not to edit this file, but instead to +;;;; tweak customize-target-features.lisp. (You must create this file +;;;; first; it is not in the SBCL distribution, and is in fact +;;;; explicitly excluded from the distribution in places like +;;;; .cvsignore.) If you define a function in +;;;; customize-target-features.lisp, it will be used to transform the +;;;; target features list after it's read and before it's used. E.g., +;;;; you can use code like this: +;;;; (lambda (list) +;;;; (flet ((enable (x) (pushnew x list)) +;;;; (disable (x) (setf list (remove x list)))) +;;;; #+nil (enable :sb-show) +;;;; (enable :sb-after-xc-core) +;;;; #+nil (disable :sb-doc) +;;;; list)) +;;;; By thus editing a local file (one which is not in the source +;;;; distribution, and which is in .cvsignore) your customizations +;;;; will remain local even if you do things like "cvs update", +;;;; will not show up if you try to submit a patch with "cvs diff", +;;;; and might even stay out of the way if you use other non-CVS-based +;;;; methods to upgrade the files or store your configuration. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +( + ;; + ;; features present in all builds + ;; + + ;; our standard + :ansi-cl :common-lisp + ;; FIXME: Isn't there a :x3jsomething feature which we should set too? + ;; No. CLHS says ":x3j13 [...] A conforming implementation might or + ;; might not contain such a feature." -- CSR, 2002-02-21 + + ;; our dialect + :sbcl + + ;; + ;; features present in this particular build + ;; + + ;; Setting this enables the compilation of documentation strings + ;; from the system sources into the target Lisp executable. + ;; Traditional Common Lisp folk will want this option set. + ;; I (WHN) made it optional because I came to Common Lisp from + ;; C++ through Scheme, so I'm accustomed to asking + ;; Emacs about things that I'm curious about instead of asking + ;; the executable I'm running. + :sb-doc + + ;; Make more debugging information available (for debugging SBCL + ;; itself). If you aren't hacking or troubleshooting SBCL itself, + ;; you probably don't want this set. + ;; + ;; At least two varieties of debugging information are enabled by this + ;; option: + ;; * SBCL is compiled with a higher level of OPTIMIZE DEBUG, so that + ;; the debugger can tell more about the state of the system. + ;; * Various code to print debugging messages, and similar debugging code, + ;; is compiled only when this feature is present. + ;; + ;; Note that the extra information recorded by the compiler at + ;; this higher level of OPTIMIZE DEBUG includes the source location + ;; forms. In order for the debugger to use this information, it has to + ;; re-READ the source file. In an ordinary installation of SBCL, this + ;; re-READing may not work very well, for either of two reasons: + ;; * The sources aren't present on the system in the same location that + ;; they were on the system where SBCL was compiled. + ;; * SBCL is using the standard readtable, without the added hackage + ;; which allows it to handle things like target features. + ;; If you want to be able to use the extra debugging information, + ;; therefore, be sure to keep the sources around, and run with the + ;; readtable configured so that the system sources can be read. + ; :sb-show + + ;; Enable the low level debugger, "ldb", by default. In the ideal + ;; world you would not need this unless you are messing with SBCL at + ;; a very low level (e.g., trying to diagnose GC problems, or trying + ;; to debug assembly code for a port to a new CPU). However, + ;; experience shows that sooner or later everyone lose()'s, in which + ;; case SB-LDB can at least provide an informative backtrace. + :sb-ldb + + ;; This isn't really a target Lisp feature at all, but controls + ;; whether the build process produces an after-xc.core file. This + ;; can be useful for shortening the edit/compile/debug cycle when + ;; you modify SBCL's own source code, as in slam.sh. Otherwise + ;; you don't need it. + ; :sb-after-xc-core + + ;; Enable extra debugging output in the assem.lisp assembler/scheduler + ;; code. (This is the feature which was called :DEBUG in the + ;; original CMU CL code.) + ; :sb-show-assem + + ;; Compile the C runtime with support for low-level debugging output + ;; through FSHOW and FSHOW_SIGNAL. If enabled, this feature allows + ;; users to turn on such debugging output using environment variables at + ;; run-time. + ; :sb-qshow + + ;; Setting this makes SBCL more "fluid", i.e. more amenable to + ;; modification at runtime, by suppressing various INLINE declarations, + ;; compiler macro definitions, FREEZE-TYPE declarations; and by + ;; suppressing various burning-our-ships-behind-us actions after + ;; initialization is complete; and so forth. This tends to clobber the + ;; performance of the system, so unless you have some special need for + ;; this when hacking SBCL itself, you don't want this set. + ; :sb-fluid + + ;; Enable code for collecting statistics on usage of various operations, + ;; useful for performance tuning of the SBCL system itself. This code + ;; is probably pretty stale (having not been tested since the fork from + ;; base CMU CL) but might nonetheless be a useful starting point for + ;; anyone who wants to collect such statistics in the future. + ; :sb-dyncount + + ;; Enable code for detecting concurrent accesses to the same hash-table + ;; in multiple threads. Note that this implementation is currently + ;; (2007-09-11) somewhat too eager: even though in the current implementation + ;; multiple readers are thread safe as long as there are no writers, this + ;; code will also trap multiple readers. + ; :sb-hash-table-debug + + ;; Enabled automatically by make-config.sh for platforms which implement + ;; short vector SIMD intrinsics. + ;; + ; :sb-simd-pack + + ;; Enabled automatically by make-config.sh for platforms which implement + ;; the %READ-CYCLE-COUNTER VOP. Can be disabled manually: affects TIME. + ;; + ;; FIXME: Should this be :SB-CYCLE-COUNTER instead? If so, then the same goes + ;; for :COMPARE-AND-SWAP-VOPS as well, and a bunch of others. Perhaps + ;; built-time convenience features like this should all live in eg. SB-INT + ;; instead? + ;; + ; :cycle-counter + + ;; Build with support for an additional dynamic heap + ;; differing from the main dynamic heap in two ways: + ;; 1. it is guaranteed to reside below 4GB so that all pointers + ;; into it fit in 32 bits. (Only an issue for >32 bit address space) + ;; 2. all objects therein are immovable, and space is reclaimed + ;; by a mark-and-sweep collector. + ;; That combination of aspects potentially allows various efficiencies + ;; in code generation, especially for the x86-64 backend. + ;; The extra space has a fixed size which can only be changed by a rebuild, + ;; and out-of-space conditions are not easily preventable, so the space + ;; is sized rather generously to sidestep the issue. + ;; Additionally, it is assumed that for all objects in the immobile heap, + ;; speed of allocation of those objects is relatively unimportant. + ;; If unexpected performance regressions are observed, + ;; consider disabling this feature and reporting a bug. + ; :immobile-space + + ;; Allocate most functions in the immobile space. + ;; Enabled by default if supported. + ;; The down-side of this feature is that the allocator is significantly + ;; slower than the allocator for movable code. If a particular application + ;; is performance-constrained by speed of creation of compiled functions + ;; (not including closures), the feature can be disabled. + ; :immobile-code + + ;; Combine the layout pointer, instance-length, and widetag of INSTANCE + ;; into a single machine word. This represents a space savings of anywhere + ;; from 4% to 8% in typical applications. (Your mileage may vary). + ; :compact-instance-header + + ;; Peter Van Eynde's increase-bulletproofness code for CMU CL + ;; + ;; Some of the code which was #+high-security before the fork has now + ;; been either made unconditional, deleted, or rewritten into + ;; unrecognizability, but some remains. What remains is not maintained + ;; or tested in current SBCL, but I haven't gone out of my way to + ;; break it, either. + ;; + ; :high-security + ; :high-security-support + + ;; low-level thread primitives support + ;; + ;; As of SBCL 1.0.33.26, threads are part of the default build on + ;; x86oid Linux. Other platforms that support them include + ;; x86oid Darwin, FreeBSD, and Solaris. + ; :sb-thread + + ;; futex support + ;; + ;; While on linux we are able to use futexes for our locking + ;; primitive, on other platforms we don't have this luxury. + ;; + ; :sb-futex + + ;; Support for detection of unportable code (when applied to the + ;; COMMON-LISP package, or SBCL-internal pacakges) or bad-neighbourly + ;; code (when applied to user-level packages), relating to material + ;; alteration to packages or to bindings in symbols in packages. + :sb-package-locks + + ;; Support for the entirety of the 21-bit character space defined by + ;; the Unicode consortium, rather than the classical 8-bit ISO-8859-1 + ;; character set. + :sb-unicode + + ;; Support for a full evaluator that can execute all the CL special + ;; forms, as opposed to the traditional SBCL evaluator which called + ;; COMPILE for everything complicated. + :sb-eval + ;; Support for a different evaluator (interpreter) with improved performance. + ;; You can't have both. + ; :sb-fasteval + + ;; Record source location information for variables, classes, conditions, + ;; packages, etc. Gives much better information on M-. in Slime, but + ;; increases core size by about 100kB. + :sb-source-locations + + ;; Record xref data for SBCL internals. This can be rather useful for + ;; people who want to develop on SBCL itself because it'll make M-? + ;; (slime-edit-uses) work which lists call/expansion/etc. sites. + ;; It'll increase the core size by major 5-6mB, though. + ; :sb-xref-for-internals + + ;; We support package local nicknames. No :sb-prefix here as we vainly + ;; believe our API is worth copying to other implementations as well. + ;; This doesn't affect the build at all, merely declares how things are. + :package-local-nicknames + + ;; This is set in classic CMU CL, and presumably there it means + ;; that the floating point arithmetic implementation + ;; conforms to IEEE's standard. Here it definitely means that the + ;; floating point arithmetic implementation conforms to IEEE's standard. + ;; I (WHN 19990702) haven't tried to verify + ;; that it does conform, but it should at least mostly conform (because + ;; the underlying x86 hardware tries). + :ieee-floating-point + + ;; CMU CL had, and we inherited, code to support 80-bit LONG-FLOAT on the x86 + ;; architecture. Nothing has been done to actively destroy the long float + ;; support, but it hasn't been thoroughly maintained, and needs at least + ;; some maintenance before it will work. (E.g. the LONG-FLOAT-only parts of + ;; genesis are still implemented in terms of unportable CMU CL functions + ;; which are not longer available at genesis time in SBCL.) A deeper + ;; problem is SBCL's bootstrap process implicitly assumes that the + ;; cross-compilation host will be able to make the same distinctions + ;; between floating point types that it does. This assumption is + ;; fundamentally sleazy, even though in practice it's unlikely to break down + ;; w.r.t. distinguishing SINGLE-FLOAT from DOUBLE-FLOAT; it's much more + ;; likely to break down w.r.t. distinguishing DOUBLE-FLOAT from LONG-FLOAT. + ;; Still it's likely to be quite doable to get LONG-FLOAT support working + ;; again, if anyone's sufficiently motivated. + ; :long-float + + ;; Some platforms don't use a 32-bit off_t by default, and thus can't + ;; handle files larger than 2GB. This feature will control whether + ;; we'll try to use platform-specific compilation options to enable a + ;; 64-bit off_t. The intent is for this feature to be automatically + ;; enabled by make-config.sh on platforms where it's needed and known + ;; to work, you shouldn't be enabling it manually. You might however + ;; want to disable it, if you need to pass file descriptors to + ;; foreign code that uses a 32-bit off_t. + ; :largefile + + ;; SBCL has optional support for zlib-based compressed core files. Enable + ;; this feature to compile it in. Obviously, doing so adds a dependency + ;; on zlib. + ; :sb-core-compression + + ;; On certain thread-enabled platforms, synchronization between threads + ;; for the purpose of stopping and starting the world around GC can be + ;; performed using safepoints instead of signals. Enable this feature + ;; to compile with safepoints and to use them for GC. + ;; (Replaces use of SIG_STOP_FOR_GC.) + ; :sb-safepoint + + ;; + ;; miscellaneous notes on other things which could have special significance + ;; in the *FEATURES* list + ;; + + ;; Any target feature which affects binary compatibility of fasl files + ;; needs to be recorded in *FEATURES-POTENTIALLY-AFFECTING-FASL-FORMAT* + ;; (elsewhere). + + ;; notes on the :NIL and :IGNORE features: + ;; + ;; #+NIL is used to comment out forms. Occasionally #+IGNORE is used + ;; for this too. So don't use :NIL or :IGNORE as the names of features.. + + ;; notes on :SB-XC and :SB-XC-HOST features (which aren't controlled by this + ;; file, but are instead temporarily pushed onto *FEATURES* or + ;; *TARGET-FEATURES* during some phases of cross-compilation): + ;; + ;; :SB-XC-HOST stands for "cross-compilation host" and is in *FEATURES* + ;; during the first phase of cross-compilation bootstrapping, when the + ;; host Lisp is being used to compile the cross-compiler. + ;; + ;; :SB-XC stands for "cross compiler", and is in *FEATURES* during the second + ;; phase of cross-compilation bootstrapping, when the cross-compiler is + ;; being used to create the first target Lisp. + + ;; notes on the :SB-ASSEMBLING feature (which isn't controlled by + ;; this file): + ;; + ;; This is a flag for whether we're in the assembler. It's + ;; temporarily pushed onto the *FEATURES* list in the setup for + ;; the ASSEMBLE-FILE function. It would be a bad idea + ;; to use it as a name for a permanent feature. + + ;; notes on local features (which are set automatically by the + ;; configuration script, and should not be set here unless you + ;; really, really know what you're doing): + ;; + ;; machine architecture features: + ;; :x86 + ;; any Intel 386 or better, or compatibles like the AMD K6 or K7 + ;; :x86-64 + ;; any x86-64 CPU running in 64-bit mode + ;; :sparc + ;; any Sun UltraSPARC (possibly also non-Ultras -- currently untested) + ;; :ppc + ;; any PowerPC CPU + ;; :ppc64 + ;; 64-bit PowerPC CPU, ISA 2.06 (POWER7) or later + ;; :mips + ;; any MIPS CPU (in little-endian mode with :little-endian) + ;; :arm + ;; an ARM CPU (details yet to be determined) + ;; :arm64 + ;; an ARMv8 AArch64 CPU + ;; :riscv + ;; A RISC-V CPU. + ;; (CMU CL also had a :pentium feature, which affected the definition + ;; of some floating point vops. It was present but not enabled or + ;; documented in the CMU CL code that SBCL is derived from, and has + ;; now been moved to the backend-subfeatures mechanism.) + ;; + ;; properties derived from the machine architecture + ;; + ;; :64-bit + ;; means (= sb-vm:n-word-bits 64) currently true for x86-64, arm64, riscv64, ppc64 + ;; + ;; :64-bit-registers + ;; means (= sb-vm:n-machine-word-bits 64), yet (= sb-vm:n-word-bits 32) currently true for alpha + ;; + ;; :control-stack-grows-downward-not-upward + ;; On the X86, the Lisp control stack grows downward. On the + ;; other supported CPU architectures as of sbcl-0.7.1.40, the + ;; system stack grows upward. + ;; Note that there are other stack-related differences between the + ;; X86 port and the other ports. E.g. on the X86, the Lisp control + ;; stack coincides with the C stack, meaning that on the X86 there's + ;; stuff on the control stack that the Lisp-level debugger doesn't + ;; understand very well. As of sbcl-0.7.1.40 things like that are + ;; just parameterized by #+X86, but it'd probably be better to + ;; use new flags like :CONTROL-STACK-CONTAINS-C-STACK. + ;; + ;; :alien-callbacks + ;; Alien callbacks have been implemented for this platform. + ;; + ;; :compare-and-swap-vops + ;; The backend implements compare-and-swap VOPs. + ;; + ;; operating system features: + ;; :unix = We're intended to run under some Unix-like OS. (This is not + ;; exclusive with the features which indicate which particular + ;; Unix-like OS we're intended to run under.) + ;; :linux = We're intended to run under some version of Linux. + ;; :bsd = We're intended to run under some version of BSD Unix. (This + ;; is not exclusive with the features which indicate which + ;; particular version of BSD we're intended to run under.) + ;; :freebsd = We're intended to run under FreeBSD. + ;; :openbsd = We're intended to run under OpenBSD. + ;; :netbsd = We're intended to run under NetBSD. + ;; :dragonfly = We're intended to run under DragonFly BSD. + ;; :darwin = We're intended to run under Darwin (including MacOS X). + ;; :sunos = We're intended to run under Solaris user environment + ;; with the SunOS kernel. + ;; :win32 = We're intended to under some version of Microsoft Windows. + ) diff -Nru sbcl-2.1.1/src/cold/build-order.lisp-expr sbcl-2.1.11/src/cold/build-order.lisp-expr --- sbcl-2.1.1/src/cold/build-order.lisp-expr 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/cold/build-order.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,726 @@ +;;;; -*- Lisp -*- + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +;;; a linear ordering of system sources which works both to +;;; compile/load the cross-compiler under the host Common Lisp and +;;; then to cross-compile the complete system into the +;;; under-construction target SBCL +;;; +;;; The keyword flags (:NOT-HOST, :NOT-TARGET, :ASSEM...) are +;;; documented in the code which implements their effects. (As of +;;; sbcl-0.7.10, the comments are on DEFPARAMETER *EXPECTED-STEM-FLAGS* +;;; in src/cold/shared.lisp.) +;;; +;;; Of course, it'd be very nice to have this be a dependency DAG +;;; instead, so that we could do automated incremental recompilation. +;;; But the dependencies are varied and subtle, and it'd be extremely +;;; difficult to extract them automatically, and it'd be extremely +;;; tedious and error-prone to extract them manually, so we don't +;;; extract them. (It would be nice to fix this someday. The most +;;; feasible approach that I can think of would be to make the +;;; dependencies work on a package level, not an individual file +;;; level. Doing it at the package level would make the granularity +;;; coarse enough that it would probably be pretty easy to maintain +;;; the dependency information manually, and the brittleness of the +;;; package system would help make most violations of the declared +;;; dependencies obvious at build time. -- WHN 20000803 + +;;; make-host-n build steps +;;; All uses of #+ and #- reader macros within this file refer to +;;; the chosen target features, and not CL:*FEATURES*. +;;; If you must test a host feature, use "#.(cl:if ..)" syntax. +( + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; miscellaneous + + ("src/code/cross-early" :c-headers :not-target) + + ;; This comes early because it's useful for debugging everywhere. + ("src/code/show" :c-headers) + ("src/compiler/early-constantp" :c-headers) + ("src/code/defsetfs" :not-host) + + ;; Declare all target special variables defined by ANSI + ("src/code/cl-specials" :not-host) + + ;; Things like DX-FLET and AWHEN are available for use in both the + ;; host and target very early. + ("src/code/primordial-extensions" :c-headers) + ("src/code/cold-init-helper-macros" :c-headers) + ("src/code/early-defmethod" :not-host) + + ;; ASAP we replace the host's backquote reader with our own, to avoid leaking + ;; details of the host into the target. This is not a concern in make-host-2 + ;; becase IN-TARGET-CROSS-COMPILATION-MODE assigns the reader macros before + ;; compiling anything. It is, however, a minor concern for make-host-1, but + ;; usually a problem can be exposed only by contrived code / poor style. + ;; e.g. if the host's reader were used when compiling + ;; (EVAL-WHEN (#-SB-XC :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) + ;; (DEFUN A-MACRO-HELPER () '`(FOO ,A ,B)) + ;; then A-MACRO-HELPER returns host code, and calling it might be wrong, either + ;; obviously or subtly. If the result is (LIST* 'FOO (LIST* A (LIST B))) + ;; then it's subtly wrong because it might not be the optimal strategy; + ;; whereas if it's (BACKQUOTE (FOO (UNQUOTE A) (UNQUOTE B))) then it's + ;; flat out wrong. At any rate, judicious avoidance of EVAL-WHEN and nested + ;; quasiquotation in 'primordial-extensions' prevents any such issues. + ("src/code/backq") + + ;; It's difficult to be too early with a DECLAIM SPECIAL (or DEFVAR + ;; or whatever) thanks to the sullenly-do-the-wrong-thing semantics + ;; of CL special binding when the variable is undeclared. + ("src/code/globals" :not-host) + + ("src/code/cmacros" :not-host) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; cross-compiler-only replacements for stuff which in target Lisp would be + ;;; supplied by basic machinery + + ("src/code/cross-byte" :c-headers :not-target) + ("src/code/cross-misc" :c-headers :not-target) + ("src/code/cross-char" :c-headers :not-target) + ("src/code/cross-float" :c-headers :not-target) + ("src/code/cross-io" :not-target) + ("src/code/cross-condition" :not-target) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; stuff needed early both in cross-compilation host and in target Lisp + + ("src/code/uncross" :c-headers) + + ("src/code/defbangtype" :c-headers) + ("src/code/early-constants" :c-headers) + + ("src/compiler/vop-existsp" :c-headers) + + ;; comes early so that stuff can reason about function names + ("src/code/function-names" :c-headers) + + ("src/compiler/early-globaldb" :c-headers) + ;; for various constants e.g. SB-XC:MOST-POSITIVE-FIXNUM and + ;; SB-VM:N-LOWTAG-BITS, needed by "early-objdef" and others. + ("src/compiler/generic/parms" :c-headers) + ("src/compiler/{arch}/parms" :c-headers) + ("src/compiler/generic/early-vm" :c-headers) + ("src/compiler/generic/early-objdef" :c-headers) + + ;; This has the BARRIER stuff that the threading support needs, + ;; required for some code in 'early-extensions' + ("src/code/barrier" :not-host) + ("src/code/parse-body" :c-headers) ; on host for PARSE-BODY + ("src/compiler/policy" :c-headers) + #+sb-fasteval ("src/interpreter/basic-env") + + ("src/code/early-extensions" :c-headers) ; on host for COLLECT, SYMBOLICATE, etc. + + ("src/code/defbangstruct" :c-headers :not-target) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; basic machinery for the target Lisp. Note that although most of these + ;;; files are flagged :NOT-HOST, a few might not be. + + ("src/code/ansi-stream" :not-host) + ("src/code/restart" :not-host) + ("src/code/early-print" :not-host) + ("src/code/early-pprint" :not-host) + ("src/code/early-impl" :not-host) + + ;; Needed before the first use of WITH-SINGLE-PACKAGE-LOCKED-ERROR. + ("src/code/early-package" :not-host) + + ("src/code/early-raw-slots" :c-headers) + + ("src/code/maphash" :not-host) + ("src/code/xset" :c-headers) ; for representation of MEMBER type + ;; This needs DEF!STRUCT, and is itself needed early so that structure + ;; accessors and inline functions defined here can be compiled inline + ;; later. (Avoiding full calls increases efficiency) + ("src/code/type-class" :c-headers) + + ("src/code/cas" :not-host) + ("src/code/thread-structs" :c-headers #-sb-devel :block-compile) ; some defstructs for genesis + ("src/compiler/early-c" :c-headers) + ("src/pcl/slot-name") + + ("src/code/sysmacs" :not-host) + ("src/code/early-classoid" :c-headers) + + ("src/compiler/generic/pinned-objects" :not-host) + ("src/compiler/generic/layout-ids" :c-headers) + + ("src/code/signal" :not-host) + ("src/code/cold-error" :not-host) + ;; Define at most one INTERPRETED-FUNCTION type based on target features + #+sb-eval ("src/code/early-full-eval" :not-host) + #+sb-fasteval ("src/interpreter/function" :not-host) + + ("src/code/debug-var-io") + + ("src/code/early-float") + + ("src/code/huffman") + + ;; 32-bit implementation of GET-INTERNAL-REAL-TIME needs some thread slots + ("src/code/early-time" :c-headers) + + ("src/code/misc" :c-headers) + ("src/code/early-defclass") + ("src/code/target-error" :not-host) + ("src/code/target-extensions" :not-host) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;; compiler (and a few miscellaneous files whose dependencies make it + ;;; convenient to stick them here) + + ("src/compiler/parse-lambda-list" :c-headers) + ("src/compiler/fun-info" :c-headers) + ("src/compiler/constantp" :c-headers) + ("src/compiler/macros" :c-headers) + ("src/compiler/generic/vm-macs" :c-headers) + ("src/compiler/policies") + + ("src/code/target-lfhash" :not-host) + ("src/compiler/info-vector" :c-headers) + ("src/compiler/globaldb" :c-headers) + ("src/compiler/generic/objdef" :c-headers) + + ("src/compiler/generic/vm-array" :c-headers) + ("src/code/string-hash" :c-headers) + ("src/code/primordial-type" :c-headers) + ("src/code/specializable-array" :not-target) + + ("src/compiler/sset" :c-headers) + ;; for e.g. BLOCK-ANNOTATION, needed by "compiler/vop" + ("src/compiler/node" :c-headers :block-compile) + ;; This has ASSEMBLY-UNIT-related stuff needed by core.lisp. + ;; and LABEL, needed by IR2-NLX-INFO + ("src/compiler/early-assem") + ;; for e.g. PRIMITIVE-TYPE, needed by "vmdef" + ("src/compiler/vop" :c-headers :block-compile) + ("src/compiler/backend" :c-headers) + + ;; sparc-vm and ppc-vm need sc+offset defined to get at internal + ;; error args. This file contains stuff previously in + ;; debug-info.lisp. Should it therefore be :not-host? -- CSR, + ;; 2002-02-05 + ("src/code/sc-offset" :c-headers) + + ;; for e.g. MAX-VOP-TN-REFS, needed by "meta-vmdef" + ("src/compiler/vmdef" :c-headers) + + ("src/code/defmacro" :c-headers) + ;; for e.g. !DEF-PRIMITIVE-TYPE, needed by primtype.lisp, and + ;; DEFINE-STORAGE-CLASS, needed by target/vm.lisp + ("src/compiler/meta-vmdef" :c-headers) + + ("src/compiler/fixup") ; for DEFSTRUCT FIXUP, needed by generic/core + ("src/compiler/generic/core") ; for CORE-OBJECT-P, needed by x86-64/vm + + ;; for e.g. DESCRIPTOR-REG, needed by primtype.lisp + ("src/compiler/{arch}/vm" :c-headers) + + ("src/code/alieneval" :c-headers) + ;; This is generated automatically by grovel_headers.c, i.e. it's not + ;; under source control. + ("output/stuff-groveled-from-headers" :not-host) + ("src/code/target-alieneval" :not-host) + ("src/code/target-c-call" :not-host) + + ("src/code/weak" :not-host) + ("src/code/array" :not-host) + + ("src/code/list" :not-host) + ("src/code/seq" :not-host) ; "code/seq" should come after "code/list". + ("src/code/fdefinition" :not-host) + ("src/code/coerce" :not-host) + + ;; This needs DEFINE-ALIEN-ROUTINE from target-alieneval. + ("src/code/misc-aliens" :not-host) + ("src/code/thread" :not-host #-sb-devel :block-compile) ; provides *CURRENT-THREAD* for target-signal + + ;; RANDOM-LAYOUT-CLOS-HASH (in 'class') uses RANDOM, the transform for which + ;; uses GENERATE-RANDOM-EXPR-FOR-POWER-OF-2 which becomes BIG-RANDOM-CHUNK, + ;; which wants to be inlined, and which when inlined becomes RANDOM-CHUNK, + ;; which also wants to be inlined. + ("src/code/target-random" :not-host) + ;; META-FIXME: I think I figured out why this was, and fixed that, + ;; and never removed the following comment, nor can I remember why. + ;; FIXME: Classic CMU CL had (OPTIMIZE (SAFETY 2) (DEBUG 2) declared + ;; around the compilation of "code/class". Why? + ("src/code/class" :c-headers) + ("src/pcl/pre-warm") + ("src/code/target-sxhash" :not-host) ; needs most-fooative-foo-float constants + + ("src/code/debug-info" :c-headers) + + ("src/code/source-location") + + ("src/compiler/proclaim" :c-headers) + ("src/compiler/deftype" :c-headers) ; on host for SB-XC:DEFTYPE + ("src/code/type" :c-headers) + ("src/compiler/generic/vm-type" :c-headers) + ("src/code/pred" :not-host) + + ("src/compiler/generic/primtype" :c-headers) + + ;; stuff needed by "code/defstruct" + ("src/code/cross-type" :c-headers :not-target) + + ;; Compile target-only stuff after all defglobals like *CONS-T-T-TYPE* + ;; and all type-classes are defined. + ("src/code/deftypes-for-target" :c-headers) + + ("src/code/type-init" :c-headers) + + ;; The DEFSTRUCT machinery needs SUBTYPEP, defined in + ;; "code/type", and SB-XC:TYPEP, defined in "code/cross-type", + ;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type", + ;; and PROCLAIM, defined in "src/compiler/proclaim" + ("src/code/defstruct" :c-headers) + ("src/code/target-defstruct" :not-host) + + ;; ALIEN-VALUE has to be defined as a class (done by DEFSTRUCT + ;; machinery) before we can set its superclasses here. + ("src/code/alien-type") + + ;; This needs not just the SB-XC:DEFSTRUCT machinery, but also the + ;; TYPE= stuff defined in type.lisp, and the CHECK-FUN-NAME defined + ;; in proclaim.lisp. + ("src/code/force-delayed-defbangstructs" :c-headers :not-target) + + ("src/compiler/compiler-error") + + ;; Now that the type system is initialized, fix up UNKNOWN types that + ;; have crept in. + ("src/compiler/fixup-type") + + ;; These define target types needed by fndb.lisp. + ("src/code/package" :c-headers) + ("src/code/typep" :not-host) + ("src/code/random") + ("src/code/hash-table" :c-headers) + ("src/code/readtable") + ("src/code/pathname" :not-host) + ("src/code/host-pprint") + + ("src/compiler/knownfun") + ("src/compiler/ctype") + ("src/compiler/fndb") + ("src/compiler/generic/vm-fndb") + + ("src/compiler/generic/late-objdef" :c-headers) + + ("src/compiler/generic/interr" :c-headers) + + ("src/compiler/bit-util") + + ("src/code/linkage-table" :not-host) + ("src/code/foreign" :not-host) + ("src/code/unix" :not-host) + ("src/code/symbol" :not-host) + ("src/code/bignum" :not-host #-(or bignum-assertions sb-devel) :block-compile) + ("src/code/number-dispatch" :not-host) + ("src/code/float-inf-nan" :not-host) + ("src/code/numbers" :not-host) + ("src/code/float-trap" :not-host) + ("src/code/float" :not-host) + ("src/code/irrat" :not-host) + + ("src/code/fd-stream" :not-host) + ("src/code/target-char" :not-host) + ("src/code/stream" :not-host) + ("src/code/load") + ("src/code/deadline" :not-host) + ("src/code/common-os" :not-host) + + ("src/code/format-directive") + + ("src/code/host-c-call") + + #+os-provides-dlopen ("src/code/foreign-load" :not-host) + #+(and os-provides-dlopen (not win32)) ("src/code/unix-foreign-load" :not-host) + #+(and os-provides-dlopen win32) ("src/code/win32-foreign-load" :not-host) + + ("src/code/fop") ; needs macros from code/load.lisp + + ("src/compiler/disassem") + ("src/compiler/assem") + + ;; Compiling this requires fop definitions from code/fop.lisp and + ("src/compiler/dump") + ("src/compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp + + ("src/compiler/ir1report") ; for COMPILER-ERROR-CONTEXT + ("src/compiler/main") ; needs DEFSTRUCT FASL-OUTPUT from dump.lisp + ("src/compiler/xref") + ("src/compiler/target-main" :not-host) + ("src/compiler/ir1tran") + ("src/compiler/ir1tran-lambda") + ("src/compiler/ir1-translators") + ("src/compiler/ir1util") + ("src/compiler/callable-args") + ("src/compiler/locall") + ("src/compiler/ir1opt") + ("src/compiler/loop") + + ("src/compiler/ir1final") + ("src/compiler/constraint") + ("src/compiler/equality-constraints") + ("src/compiler/array-tran") + ("src/compiler/seqtran") + ("src/compiler/saptran") + ("src/compiler/modarith") + ("src/compiler/sxhash") + ("src/code/quantifiers") + ("src/compiler/bitops-derive-type") + + ("src/compiler/dfo") + ("src/compiler/dce") + ("src/compiler/checkgen") + + ("src/compiler/tn") + ("src/compiler/life") + + ("src/compiler/debug-dump") + ("src/compiler/generic/utils" :c-headers) + ("src/compiler/fopcompile") + + ("src/assembly/assemfile" :not-target) + + ("src/compiler/target-dstate" :not-host) + ("src/compiler/asm-target/insts") + #+avx2 ("src/compiler/{arch}/avx2-insts") + ("src/compiler/{arch}/macros") + + ("src/assembly/{arch}/support") + + ("src/compiler/{arch}/move") + ("src/compiler/{arch}/float") + #+sb-simd-pack ("src/compiler/{arch}/simd-pack") + #+sb-simd-pack-256 ("src/compiler/{arch}/simd-pack-256") + ("src/compiler/{arch}/sap") + ("src/compiler/{arch}/system") + ("src/compiler/{arch}/char") + ("src/compiler/{arch}/memory") + ("src/compiler/{arch}/arith") + ("src/compiler/{arch}/pred") + + ;; this file defines the INTERVAL struct which is also used in 'srctran' + ("src/compiler/float-tran") + ;; This is a terrible name for a file that contains type derivers + ;; and IR1 transforms. Maybe split it up into more appropriately named pieces. + ("src/compiler/srctran") + ("src/compiler/generic/vm-tran") + ("src/compiler/generic/type-vops") + ("src/compiler/{arch}/type-vops") + ("src/compiler/typetran") + ("src/compiler/generic/vm-typetran") + ("src/code/cross-modular" :not-target) + + ("src/compiler/{arch}/subprim") + ("src/compiler/{arch}/debug") + ("src/compiler/{arch}/c-call") + ("src/compiler/{arch}/cell") + ("src/compiler/{arch}/values") + ("src/compiler/{arch}/alloc") + ("src/compiler/{arch}/call") + ("src/compiler/{arch}/nlx") + ("src/compiler/generic/late-nlx") + ("src/compiler/{arch}/show") + ("src/compiler/{arch}/array") + ("src/compiler/generic/type-error") + ("src/compiler/envanal") + + ;; KLUDGE: The assembly files need to be compiled twice: once as + ;; normal lisp files, and once by sb-c:assemble-file. We use a + ;; different suffix / "file type" for the :assem versions to make + ;; sure we don't scribble over anything we shouldn't. + + ("src/assembly/{arch}/assem-rtns") + ("src/assembly/{arch}/array") + ("src/assembly/{arch}/arith") + ("src/assembly/{arch}/alloc") + ;; assembly files are all loaded by genesis before any compiled files. + ("src/assembly/master" :assem :not-host) + + ("src/compiler/pseudo-vops") + + ("src/compiler/aliencomp") + + ("src/compiler/ltv") + ("src/compiler/gtn") + ("src/compiler/ltn") + ("src/compiler/stack") + ("src/compiler/control") + ("src/compiler/entry") + ("src/compiler/ir2tran") + + ("src/compiler/generic/vm-ir2tran") + + ("src/compiler/copyprop") + ("src/compiler/represent") + ("src/compiler/ir2opt") + ("src/compiler/pack") + ("src/compiler/pack-iterative") + ("src/compiler/codegen") + ("src/compiler/debug") + + #+sb-dyncount ("src/compiler/dyncount") + #+sb-dyncount ("src/code/dyncount") + + ("src/code/format-time" :not-host) + + ;; needed by various unhappy-path cases in the cross-compiler + ("src/code/error") + ("src/code/parse-defmacro-errors") + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; files which depend in some way (directly or indirectly) on stuff + ;; compiled as part of the compiler + + ("src/code/macroexpand") + ("src/code/target-unicode" :not-host) + ("src/code/mipsstrops" :not-host) + ("src/code/string" :not-host) + ("src/code/funutils" :not-host) + + #+win32 ("src/code/win32" :not-host) + #+android ("src/code/android-os" :not-host) + #+sunos ("src/code/sunos-os" :not-host) + #+bsd ("src/code/bsd-os" :not-host) + #+linux ("src/code/linux-os" :not-host) + #+haiku ("src/code/haiku-os" :not-host) + #+win32 ("src/code/win32-os" :not-host) + + ("src/code/share-vm" :not-host) + + ;; KLUDGE: I'd prefer to have this done with a "code/target" softlink + ;; instead of a bunch of reader macros. -- WHN 19990308 + #+sparc ("src/code/sparc-vm" :not-host) + #+x86 ("src/code/x86-vm" :not-host) + #+x86-64("src/code/x86-64-vm" :not-host) + #+(or ppc ppc64) ("src/code/ppc-vm" :not-host) + #+mips ("src/code/mips-vm" :not-host) + #+arm ("src/code/arm-vm" :not-host) + #+arm64 ("src/code/arm64-vm" :not-host) + #+riscv ("src/code/riscv-vm" :not-host) + + ("src/code/target-signal-common" :not-host) + #+unix ("src/code/target-signal" :not-host) ; needs OS-CONTEXT-T from share-vm + #+win32 ("src/code/target-exception" :not-host) + ("src/code/serve-event" :not-host) + + ("src/code/late-extensions") ; needs condition system + ("src/compiler/generic/target-core" :not-host) ; uses stuff from + ; "compiler/generic/core" + + ("src/code/alloc" :not-host) ; needs foo-SPACE-START + #+metaspace ("src/code/metaspace" :not-host) + ("src/code/simple-fun" :not-host) ; function slot accessors + ("src/code/eval" :not-host) ; uses INFO, wants compiler macro + ("src/code/toplevel" :not-host) + ("src/code/time" :not-host) + ("src/code/target-package" :not-host) ; needs "code/package" + ("src/code/bignum-random" :not-host) ; needs "code/random" and + ; "code/bignum" + ("src/code/target-hash-table" :not-host) ; needs "code/hash-table" + ("src/code/query" :not-host) + ("src/code/sort" :not-host) + ("src/code/final" :not-host) + ("src/code/pprint" :not-host) ; defines WITH-PRETTY-STREAM needed by 'print' + ("src/code/reader" :not-host) ; needs "code/readtable" + ("src/code/print" :not-host) + + ("src/code/target-stream" :not-host) ; needs WHITESPACEP from "code/reader" + ("src/code/target-pathname" :not-host) + #-win32 ("src/code/unix-pathname" :not-host) + #+win32 ("src/code/win32-pathname" :not-host) + ("src/code/filesys" :not-host) ; needs HOST from "code/pathname" + + ("src/code/target-misc" :not-host) ; dribble-stream, used by "save" + ("src/code/sharpm" :not-host) ; uses stuff from "code/reader" + + ("src/code/early-step") ; target-thread needs *STEP-OUT* + + ("src/code/gc" :not-host) + ("src/code/avltree" :not-host) + ("src/code/target-thread" :not-host) + ("src/code/timer" :not-host) + + ("src/code/error-error" :not-host) ; needs WITH-STANDARD-IO-SYNTAX macro + ;; defines SB-DI:DO-DEBUG-FUN-BLOCKS, needed by target-disassem.lisp + ("src/code/debug-int" :not-host) + ("src/code/interr" :not-host) + + ("src/code/target-load" :not-host) ; for *assembler-routines*, needed by target-disassem + + ;; target-only assemblerish stuff + ("src/compiler/target-disassem" :not-host) + ("src/compiler/asm-target/target-insts" :not-host) + #+avx2 ("src/compiler/{arch}/target-avx2-insts" :not-host) + + ("src/code/debug" :not-host) + + ("src/code/octets" :not-host) + ("src/code/external-formats/enc-basic" :not-host) + #+sb-unicode ("src/code/external-formats/enc-ucs" :not-host) ; win32 needs this + + #+sb-eval ("src/code/full-eval" :not-host) ; uses INFO, ARG-COUNT-ERROR + + ("src/code/bit-bash" :not-host) ; needs %NEGATE from assembly/{arch}/arith + + #-(or x86 x86-64) ("src/compiler/generic/sanctify" :not-host) + + ("src/code/cold-init" :not-host) ; needs (SETF EXTERN-ALIEN) macroexpansion + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; target macros and DECLAIMs installed at build-the-cross-compiler time + + ;; FIXME: here? earlier? can probably be as late as possible. Also + ;; maybe call it FORCE-DELAYED-PROCLAIMS? + ("src/compiler/late-proclaim") + + ("src/code/setf") + ("src/code/macros") + ("src/code/loop") + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; other target-code-building stuff which can't be processed until + ;; machinery like SB-XC:DEFMACRO exists + + ("src/code/format") ; needs SB-XC:DEFMACRO + ("src/code/target-format" :not-host) + + ("src/code/late-globaldb" :not-host) + ("src/code/redblack" :not-host) + ;; This file, which must be last, contains sanity-checks of the cross-compile. + ;; The inputs and outputs of certain functions (currently just SXHASH) are stored + ;; in global symbols. Relying on the fact that data are easily dumped as constants + ;; (assuming we don't have a genesis bug), the forms in this file can audit + ;; whether things came out right. + ("src/code/last-file" :not-host)) + +;;; make-target-2 build steps +(("src/code/early-ntrace" ; lets PCL hook into tracing + "src/code/room" ; for MAP-ALLOCATED-OBJECTS + #+immobile-code "src/code/immobile-space" ; needs src/code/room + ;; Delay (re)defining WARN until after remove-static-links works. + ;; The definition in cold-error is good enough for self-build. + "src/code/warm-error" + "src/code/icf" + ;; We re-nickname SB-SEQUENCE as SEQUENCE now. + ;; It could be done in genesis, but not earlier, + ;; since the host has a package of that name. + "src/code/defpackage" + "src/code/target-lflist" + "src/pcl/walk") ; needs DEFPACKAGE + + #+sb-fasteval + ("src/interpreter/macros" + "src/interpreter/checkfuns" + "src/interpreter/env" + "src/interpreter/sexpr" + "src/interpreter/special-forms" + "src/interpreter/eval" + "src/interpreter/debug") + + ;; For an easy core size decreases by 3.5% put :UNICODE-LITE in features to exclude + ;; a few external-formats that you'll probably never need. + ;; Even better would be if they were all demand-loadable. + #+sb-unicode ("src/code/external-formats/enc-utf") + #-unicode-lite ("src/code/external-formats/enc-ebcdic") + #+(and sb-unicode (not unicode-lite)) + ("src/code/external-formats/enc-cyr" + "src/code/external-formats/enc-dos" + "src/code/external-formats/enc-iso" + "src/code/external-formats/enc-win" + "src/code/external-formats/enc-mac" + "src/code/external-formats/mb-util" + "src/code/external-formats/enc-cn-tbl" + "src/code/external-formats/enc-cn" + "src/code/external-formats/enc-jpn-tbl" + "src/code/external-formats/enc-jpn") + + ("src/code/stubs") + + ;; CLOS, derived from the PCL reference implementation + ;; + ;; This PCL build order is based on a particular + ;; (arbitrary) linearization of the declared build + ;; order dependencies from the old PCL defsys.lisp + ;; dependency database. + ("src/pcl/low" + "src/pcl/macros" + "src/pcl/compiler-support" + "src/pcl/defclass" + "src/pcl/defs" + "src/pcl/fngen" + "src/pcl/wrapper" + "src/pcl/cache" + "src/pcl/dlisp" + "src/pcl/boot" + "src/pcl/vector" + "src/pcl/slots-boot" + "src/pcl/combin" + "src/pcl/dfun" + "src/pcl/ctor" + "src/pcl/braid" + "src/pcl/dlisp3" + "src/pcl/generic-functions" + "src/pcl/slots" + "src/pcl/init" + "src/pcl/std-class" + "src/pcl/cpl" + "src/pcl/fsc" + "src/pcl/methods" + "src/pcl/fixup" + "src/pcl/call-next-method" + "src/pcl/defcombin" + "src/pcl/ctypes" + "src/pcl/env" + "src/pcl/documentation" + "src/pcl/print-object" + "src/pcl/precom1" + "src/pcl/precom2" + "src/code/ntrace") + + ("src/code/setf-funs" + ;; miscellaneous functionality which depends on CLOS + "src/code/late-condition" + + ;; CLOS-level support for the Gray OO streams + ;; extension (which is also supported by various + ;; lower-level hooks elsewhere in the code) + "src/pcl/gray-streams-class" + "src/pcl/gray-streams" + + ;; CLOS-level support for User-extensible sequences. + "src/pcl/sequence" + + ;; other functionality not needed for cold init, moved + ;; to warm init to reduce peak memory requirement in + ;; cold init + "src/code/describe" + + "src/code/describe-policy" + "src/code/inspect" + "src/code/profile" + #+(and x86-64 sb-thread (not gs-seg)) "src/code/aprof" ; precise allocation profiler + "src/code/step" + "src/code/warm-lib" + "src/code/alien-callback" + "src/code/run-program" + #+win32 "src/code/warm-mswin" + #+gencgc "src/code/traceroot" + + "src/code/repack-xref" + #+cheneygc "src/code/purify" + "src/code/module" + "src/code/save")) diff -Nru sbcl-2.1.1/src/cold/chill.lisp sbcl-2.1.11/src/cold/chill.lisp --- sbcl-2.1.1/src/cold/chill.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/chill.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -23,14 +23,15 @@ (defstruct package-data name doc shadow export reexport import-from use) (export 'package-data) -(dolist (data (with-open-file (f (merge-pathnames "../../package-data-list.lisp-expr" - *load-pathname*)) +(dolist (data (with-open-file (f (merge-pathnames "package-data-list.lisp-expr" *load-pathname*)) (read f))) (labels ((flatten (tree) (mapcan (lambda (x) (if (listp x) (flatten x) (list x))) tree))) (let ((*package* (find-package (package-data-name data)))) - (export (mapcar 'intern (flatten (package-data-export data))))))) + (dolist (x (flatten (package-data-export data))) + (let ((symbol (intern x))) + (ignore-errors (export symbol))))))) (sb-ext:unlock-package "CL") (rename-package "COMMON-LISP" "COMMON-LISP" @@ -41,17 +42,13 @@ (when (sb-int:system-package-p (find-package name)) (sb-ext:unlock-package package)))) -;;; Define this first to avoid a style-warning from 'shebang' +;;; Restore target floating-point number syntax (defun read-target-float (stream char) (declare (ignore stream char)) (values)) ; ignore the $ as if it weren't there (compile 'read-target-float) (set-macro-character #\$ #'read-target-float t) -;; Restore !DEFINE-LOAD-TIME-GLOBAL macro -(setf (macro-function 'sb-int::!define-load-time-global) - (macro-function 'sb-ext:define-load-time-global)) - (unless (fboundp 'sb-int:!cold-init-forms) (defmacro sb-int:!cold-init-forms (&rest forms) `(progn ,@forms))) @@ -63,8 +60,4 @@ (macro-function 'sb-int:/show0) (macro-function 'sb-int:/show) (macro-function 'sb-int:/noshow0) (macro-function 'sb-int:/show))) -sb-c::(defun %vop-existsp (name query &optional optimistic) - (declare (ignore optimistic)) - (not (null (ecase query - (:translate (awhen (info :function :info name) (fun-info-templates it))) - (:named (gethash name *backend-template-names*)))))) +(load "SYS:src;compiler;vop-existsp.lisp") diff -Nru sbcl-2.1.1/src/cold/common-lisp-exports.lisp-expr sbcl-2.1.11/src/cold/common-lisp-exports.lisp-expr --- sbcl-2.1.1/src/cold/common-lisp-exports.lisp-expr 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/cold/common-lisp-exports.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,477 @@ +;;; symbols exported from the COMMON-LISP package (from the ANSI spec, +;;; section 1.9, figures 1-4 to 1-15, inclusive) +( + ;; from figure 1-4: + "&ALLOW-OTHER-KEYS" "*PRINT-MISER-WIDTH*" + "&AUX" "*PRINT-PPRINT-DISPATCH*" + "&BODY" "*PRINT-PRETTY*" + "&ENVIRONMENT" "*PRINT-RADIX*" + "&KEY" "*PRINT-READABLY*" + "&OPTIONAL" "*PRINT-RIGHT-MARGIN*" + "&REST" "*QUERY-IO*" + "&WHOLE" "*RANDOM-STATE*" + "*" "*READ-BASE*" + "**" "*READ-DEFAULT-FLOAT-FORMAT*" + "***" "*READ-EVAL*" + "*BREAK-ON-SIGNALS*" "*READ-SUPPRESS*" + "*COMPILE-FILE-PATHNAME*" "*READTABLE*" + "*COMPILE-FILE-TRUENAME*" "*STANDARD-INPUT*" + "*COMPILE-PRINT*" "*STANDARD-OUTPUT*" + "*COMPILE-VERBOSE*" "*TERMINAL-IO*" + "*DEBUG-IO*" "*TRACE-OUTPUT*" + "*DEBUGGER-HOOK*" "+" + "*DEFAULT-PATHNAME-DEFAULTS*" "++" + "*ERROR-OUTPUT*" "+++" + "*FEATURES*" "-" + "*GENSYM-COUNTER*" "/" + "*LOAD-PATHNAME*" "//" + "*LOAD-PRINT*" "///" + "*LOAD-TRUENAME*" "/=" + "*LOAD-VERBOSE*" "1+" + "*MACROEXPAND-HOOK*" "1-" + "*MODULES*" "<" + "*PACKAGE*" "<=" + "*PRINT-ARRAY*" "=" + "*PRINT-BASE*" ">" + "*PRINT-CASE*" ">=" + "*PRINT-CIRCLE*" "ABORT" + "*PRINT-ESCAPE*" "ABS" + "*PRINT-GENSYM*" "ACONS" + "*PRINT-LENGTH*" "ACOS" + "*PRINT-LEVEL*" "ACOSH" + "*PRINT-LINES*" "ADD-METHOD" + + ;; from figure 1-5: + "ADJOIN" "ATOM" "BOUNDP" + "ADJUST-ARRAY" "BASE-CHAR" "BREAK" + "ADJUSTABLE-ARRAY-P" "BASE-STRING" "BROADCAST-STREAM" + "ALLOCATE-INSTANCE" "BIGNUM" "BROADCAST-STREAM-STREAMS" + "ALPHA-CHAR-P" "BIT" "BUILT-IN-CLASS" + "ALPHANUMERICP" "BIT-AND" "BUTLAST" + "AND" "BIT-ANDC1" "BYTE" + "APPEND" "BIT-ANDC2" "BYTE-POSITION" + "APPLY" "BIT-EQV" "BYTE-SIZE" + "APROPOS" "BIT-IOR" "CAAAAR" + "APROPOS-LIST" "BIT-NAND" "CAAADR" + "AREF" "BIT-NOR" "CAAAR" + "ARITHMETIC-ERROR" "BIT-NOT" "CAADAR" + "ARITHMETIC-ERROR-OPERANDS" "BIT-ORC1" "CAADDR" + "ARITHMETIC-ERROR-OPERATION" "BIT-ORC2" "CAADR" + "ARRAY" "BIT-VECTOR" "CAAR" + "ARRAY-DIMENSION" "BIT-VECTOR-P" "CADAAR" + "ARRAY-DIMENSION-LIMIT" "BIT-XOR" "CADADR" + "ARRAY-DIMENSIONS" "BLOCK" "CADAR" + "ARRAY-DISPLACEMENT" "BOOLE" "CADDAR" + "ARRAY-ELEMENT-TYPE" "BOOLE-1" "CADDDR" + "ARRAY-HAS-FILL-POINTER-P" "BOOLE-2" "CADDR" + "ARRAY-IN-BOUNDS-P" "BOOLE-AND" "CADR" + "ARRAY-RANK" "BOOLE-ANDC1" "CALL-ARGUMENTS-LIMIT" + "ARRAY-RANK-LIMIT" "BOOLE-ANDC2" "CALL-METHOD" + "ARRAY-ROW-MAJOR-INDEX" "BOOLE-C1" "CALL-NEXT-METHOD" + "ARRAY-TOTAL-SIZE" "BOOLE-C2" "CAR" + "ARRAY-TOTAL-SIZE-LIMIT" "BOOLE-CLR" "CASE" + "ARRAYP" "BOOLE-EQV" "CATCH" + "ASH" "BOOLE-IOR" "CCASE" + "ASIN" "BOOLE-NAND" "CDAAAR" + "ASINH" "BOOLE-NOR" "CDAADR" + "ASSERT" "BOOLE-ORC1" "CDAAR" + "ASSOC" "BOOLE-ORC2" "CDADAR" + "ASSOC-IF" "BOOLE-SET" "CDADDR" + "ASSOC-IF-NOT" "BOOLE-XOR" "CDADR" + "ATAN" "BOOLEAN" "CDAR" + "ATANH" "BOTH-CASE-P" "CDDAAR" + + ;; from figure 1-6: + "CDDADR" "CLEAR-INPUT" "COPY-TREE" + "CDDAR" "CLEAR-OUTPUT" "COS" + "CDDDAR" "CLOSE" "COSH" + "CDDDDR" "CLRHASH" "COUNT" + "CDDDR" "CODE-CHAR" "COUNT-IF" + "CDDR" "COERCE" "COUNT-IF-NOT" + "CDR" "COMPILATION-SPEED" "CTYPECASE" + "CEILING" "COMPILE" "DEBUG" + "CELL-ERROR" "COMPILE-FILE" "DECF" + "CELL-ERROR-NAME" "COMPILE-FILE-PATHNAME" "DECLAIM" + "CERROR" "COMPILED-FUNCTION" "DECLARATION" + "CHANGE-CLASS" "COMPILED-FUNCTION-P" "DECLARE" + "CHAR" "COMPILER-MACRO" "DECODE-FLOAT" + "CHAR-CODE" "COMPILER-MACRO-FUNCTION" "DECODE-UNIVERSAL-TIME" + "CHAR-CODE-LIMIT" "COMPLEMENT" "DEFCLASS" + "CHAR-DOWNCASE" "COMPLEX" "DEFCONSTANT" + "CHAR-EQUAL" "COMPLEXP" "DEFGENERIC" + "CHAR-GREATERP" "COMPUTE-APPLICABLE-METHODS" "DEFINE-COMPILER-MACRO" + "CHAR-INT" "COMPUTE-RESTARTS" "DEFINE-CONDITION" + "CHAR-LESSP" "CONCATENATE" "DEFINE-METHOD-COMBINATION" + "CHAR-NAME" "CONCATENATED-STREAM" "DEFINE-MODIFY-MACRO" + "CHAR-NOT-EQUAL" "CONCATENATED-STREAM-STREAMS" "DEFINE-SETF-EXPANDER" + "CHAR-NOT-GREATERP" "COND" "DEFINE-SYMBOL-MACRO" + "CHAR-NOT-LESSP" "CONDITION" "DEFMACRO" + "CHAR-UPCASE" "CONJUGATE" "DEFMETHOD" + "CHAR/=" "CONS" "DEFPACKAGE" + "CHAR<" "CONSP" "DEFPARAMETER" + "CHAR<=" "CONSTANTLY" "DEFSETF" + "CHAR=" "CONSTANTP" "DEFSTRUCT" + "CHAR>" "CONTINUE" "DEFTYPE" + "CHAR>=" "CONTROL-ERROR" "DEFUN" + "CHARACTER" "COPY-ALIST" "DEFVAR" + "CHARACTERP" "COPY-LIST" "DELETE" + "CHECK-TYPE" "COPY-PPRINT-DISPATCH" "DELETE-DUPLICATES" + "CIS" "COPY-READTABLE" "DELETE-FILE" + "CLASS" "COPY-SEQ" "DELETE-IF" + "CLASS-NAME" "COPY-STRUCTURE" "DELETE-IF-NOT" + "CLASS-OF" "COPY-SYMBOL" "DELETE-PACKAGE" + + ;; from figure 1-7: + "DENOMINATOR" "EQ" + "DEPOSIT-FIELD" "EQL" + "DESCRIBE" "EQUAL" + "DESCRIBE-OBJECT" "EQUALP" + "DESTRUCTURING-BIND" "ERROR" + "DIGIT-CHAR" "ETYPECASE" + "DIGIT-CHAR-P" "EVAL" + "DIRECTORY" "EVAL-WHEN" + "DIRECTORY-NAMESTRING" "EVENP" + "DISASSEMBLE" "EVERY" + "DIVISION-BY-ZERO" "EXP" + "DO" "EXPORT" + "DO*" "EXPT" + "DO-ALL-SYMBOLS" "EXTENDED-CHAR" + "DO-EXTERNAL-SYMBOLS" "FBOUNDP" + "DO-SYMBOLS" "FCEILING" + "DOCUMENTATION" "FDEFINITION" + "DOLIST" "FFLOOR" + "DOTIMES" "FIFTH" + "DOUBLE-FLOAT" "FILE-AUTHOR" + "DOUBLE-FLOAT-EPSILON" "FILE-ERROR" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" "FILE-ERROR-PATHNAME" + "DPB" "FILE-LENGTH" + "DRIBBLE" "FILE-NAMESTRING" + "DYNAMIC-EXTENT" "FILE-POSITION" + "ECASE" "FILE-STREAM" + "ECHO-STREAM" "FILE-STRING-LENGTH" + "ECHO-STREAM-INPUT-STREAM" "FILE-WRITE-DATE" + "ECHO-STREAM-OUTPUT-STREAM" "FILL" + "ED" "FILL-POINTER" + "EIGHTH" "FIND" + "ELT" "FIND-ALL-SYMBOLS" + "ENCODE-UNIVERSAL-TIME" "FIND-CLASS" + "END-OF-FILE" "FIND-IF" + "ENDP" "FIND-IF-NOT" + "ENOUGH-NAMESTRING" "FIND-METHOD" + "ENSURE-DIRECTORIES-EXIST" "FIND-PACKAGE" + "ENSURE-GENERIC-FUNCTION" "FIND-RESTART" + + ;; from figure 1-8: + "FIND-SYMBOL" "GET-INTERNAL-RUN-TIME" + "FINISH-OUTPUT" "GET-MACRO-CHARACTER" + "FIRST" "GET-OUTPUT-STREAM-STRING" + "FIXNUM" "GET-PROPERTIES" + "FLET" "GET-SETF-EXPANSION" + "FLOAT" "GET-UNIVERSAL-TIME" + "FLOAT-DIGITS" "GETF" + "FLOAT-PRECISION" "GETHASH" + "FLOAT-RADIX" "GO" + "FLOAT-SIGN" "GRAPHIC-CHAR-P" + "FLOATING-POINT-INEXACT" "HANDLER-BIND" + "FLOATING-POINT-INVALID-OPERATION" "HANDLER-CASE" + "FLOATING-POINT-OVERFLOW" "HASH-TABLE" + "FLOATING-POINT-UNDERFLOW" "HASH-TABLE-COUNT" + "FLOATP" "HASH-TABLE-P" + "FLOOR" "HASH-TABLE-REHASH-SIZE" + "FMAKUNBOUND" "HASH-TABLE-REHASH-THRESHOLD" + "FORCE-OUTPUT" "HASH-TABLE-SIZE" + "FORMAT" "HASH-TABLE-TEST" + "FORMATTER" "HOST-NAMESTRING" + "FOURTH" "IDENTITY" + "FRESH-LINE" "IF" + "FROUND" "IGNORABLE" + "FTRUNCATE" "IGNORE" + "FTYPE" "IGNORE-ERRORS" + "FUNCALL" "IMAGPART" + "FUNCTION" "IMPORT" + "FUNCTION-KEYWORDS" "IN-PACKAGE" + "FUNCTION-LAMBDA-EXPRESSION" "INCF" + "FUNCTIONP" "INITIALIZE-INSTANCE" + "GCD" "INLINE" + "GENERIC-FUNCTION" "INPUT-STREAM-P" + "GENSYM" "INSPECT" + "GENTEMP" "INTEGER" + "GET" "INTEGER-DECODE-FLOAT" + "GET-DECODED-TIME" "INTEGER-LENGTH" + "GET-DISPATCH-MACRO-CHARACTER" "INTEGERP" + "GET-INTERNAL-REAL-TIME" "INTERACTIVE-STREAM-P" + + ;; from figure 1-9: + "INTERN" "LISP-IMPLEMENTATION-TYPE" + "INTERNAL-TIME-UNITS-PER-SECOND" "LISP-IMPLEMENTATION-VERSION" + "INTERSECTION" "LIST" + "INVALID-METHOD-ERROR" "LIST*" + "INVOKE-DEBUGGER" "LIST-ALL-PACKAGES" + "INVOKE-RESTART" "LIST-LENGTH" + "INVOKE-RESTART-INTERACTIVELY" "LISTEN" + "ISQRT" "LISTP" + "KEYWORD" "LOAD" + "KEYWORDP" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" + "LABELS" "LOAD-TIME-VALUE" + "LAMBDA" "LOCALLY" + "LAMBDA-LIST-KEYWORDS" "LOG" + "LAMBDA-PARAMETERS-LIMIT" "LOGAND" + "LAST" "LOGANDC1" + "LCM" "LOGANDC2" + "LDB" "LOGBITP" + "LDB-TEST" "LOGCOUNT" + "LDIFF" "LOGEQV" + "LEAST-NEGATIVE-DOUBLE-FLOAT" "LOGICAL-PATHNAME" + "LEAST-NEGATIVE-LONG-FLOAT" "LOGICAL-PATHNAME-TRANSLATIONS" + "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LOGIOR" + "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LOGNAND" + "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LOGNOR" + "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LOGNOT" + "LEAST-NEGATIVE-SHORT-FLOAT" "LOGORC1" + "LEAST-NEGATIVE-SINGLE-FLOAT" "LOGORC2" + "LEAST-POSITIVE-DOUBLE-FLOAT" "LOGTEST" + "LEAST-POSITIVE-LONG-FLOAT" "LOGXOR" + "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LONG-FLOAT-EPSILON" + "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LONG-FLOAT-NEGATIVE-EPSILON" + "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LONG-SITE-NAME" + "LEAST-POSITIVE-SHORT-FLOAT" "LOOP" + "LEAST-POSITIVE-SINGLE-FLOAT" "LOOP-FINISH" + "LENGTH" "LOWER-CASE-P" + "LET" "MACHINE-INSTANCE" + "LET*" "MACHINE-TYPE" + + ;; from figure 1-10: + "MACHINE-VERSION" "MASK-FIELD" + "MACRO-FUNCTION" "MAX" + "MACROEXPAND" "MEMBER" + "MACROEXPAND-1" "MEMBER-IF" + "MACROLET" "MEMBER-IF-NOT" + "MAKE-ARRAY" "MERGE" + "MAKE-BROADCAST-STREAM" "MERGE-PATHNAMES" + "MAKE-CONCATENATED-STREAM" "METHOD" + "MAKE-CONDITION" "METHOD-COMBINATION" + "MAKE-DISPATCH-MACRO-CHARACTER" "METHOD-COMBINATION-ERROR" + "MAKE-ECHO-STREAM" "METHOD-QUALIFIERS" + "MAKE-HASH-TABLE" "MIN" + "MAKE-INSTANCE" "MINUSP" + "MAKE-INSTANCES-OBSOLETE" "MISMATCH" + "MAKE-LIST" "MOD" + "MAKE-LOAD-FORM" "MOST-NEGATIVE-DOUBLE-FLOAT" + "MAKE-LOAD-FORM-SAVING-SLOTS" "MOST-NEGATIVE-FIXNUM" + "MAKE-METHOD" "MOST-NEGATIVE-LONG-FLOAT" + "MAKE-PACKAGE" "MOST-NEGATIVE-SHORT-FLOAT" + "MAKE-PATHNAME" "MOST-NEGATIVE-SINGLE-FLOAT" + "MAKE-RANDOM-STATE" "MOST-POSITIVE-DOUBLE-FLOAT" + "MAKE-SEQUENCE" "MOST-POSITIVE-FIXNUM" + "MAKE-STRING" "MOST-POSITIVE-LONG-FLOAT" + "MAKE-STRING-INPUT-STREAM" "MOST-POSITIVE-SHORT-FLOAT" + "MAKE-STRING-OUTPUT-STREAM" "MOST-POSITIVE-SINGLE-FLOAT" + "MAKE-SYMBOL" "MUFFLE-WARNING" + "MAKE-SYNONYM-STREAM" "MULTIPLE-VALUE-BIND" + "MAKE-TWO-WAY-STREAM" "MULTIPLE-VALUE-CALL" + "MAKUNBOUND" "MULTIPLE-VALUE-LIST" + "MAP" "MULTIPLE-VALUE-PROG1" + "MAP-INTO" "MULTIPLE-VALUE-SETQ" + "MAPC" "MULTIPLE-VALUES-LIMIT" + "MAPCAN" "NAME-CHAR" + "MAPCAR" "NAMESTRING" + "MAPCON" "NBUTLAST" + "MAPHASH" "NCONC" + "MAPL" "NEXT-METHOD-P" + "MAPLIST" "NIL" + + ;; from figure 1-11: + "NINTERSECTION" "PACKAGE-ERROR" + "NINTH" "PACKAGE-ERROR-PACKAGE" + "NO-APPLICABLE-METHOD" "PACKAGE-NAME" + "NO-NEXT-METHOD" "PACKAGE-NICKNAMES" + "NOT" "PACKAGE-SHADOWING-SYMBOLS" + "NOTANY" "PACKAGE-USE-LIST" + "NOTEVERY" "PACKAGE-USED-BY-LIST" + "NOTINLINE" "PACKAGEP" + "NRECONC" "PAIRLIS" + "NREVERSE" "PARSE-ERROR" + "NSET-DIFFERENCE" "PARSE-INTEGER" + "NSET-EXCLUSIVE-OR" "PARSE-NAMESTRING" + "NSTRING-CAPITALIZE" "PATHNAME" + "NSTRING-DOWNCASE" "PATHNAME-DEVICE" + "NSTRING-UPCASE" "PATHNAME-DIRECTORY" + "NSUBLIS" "PATHNAME-HOST" + "NSUBST" "PATHNAME-MATCH-P" + "NSUBST-IF" "PATHNAME-NAME" + "NSUBST-IF-NOT" "PATHNAME-TYPE" + "NSUBSTITUTE" "PATHNAME-VERSION" + "NSUBSTITUTE-IF" "PATHNAMEP" + "NSUBSTITUTE-IF-NOT" "PEEK-CHAR" + "NTH" "PHASE" + "NTH-VALUE" "PI" + "NTHCDR" "PLUSP" + "NULL" "POP" + "NUMBER" "POSITION" + "NUMBERP" "POSITION-IF" + "NUMERATOR" "POSITION-IF-NOT" + "NUNION" "PPRINT" + "ODDP" "PPRINT-DISPATCH" + "OPEN" "PPRINT-EXIT-IF-LIST-EXHAUSTED" + "OPEN-STREAM-P" "PPRINT-FILL" + "OPTIMIZE" "PPRINT-INDENT" + "OR" "PPRINT-LINEAR" + "OTHERWISE" "PPRINT-LOGICAL-BLOCK" + "OUTPUT-STREAM-P" "PPRINT-NEWLINE" + "PACKAGE" "PPRINT-POP" + + ;; from figure 1-12: + "PPRINT-TAB" "READ-CHAR" + "PPRINT-TABULAR" "READ-CHAR-NO-HANG" + "PRIN1" "READ-DELIMITED-LIST" + "PRIN1-TO-STRING" "READ-FROM-STRING" + "PRINC" "READ-LINE" + "PRINC-TO-STRING" "READ-PRESERVING-WHITESPACE" + "PRINT" "READ-SEQUENCE" + "PRINT-NOT-READABLE" "READER-ERROR" + "PRINT-NOT-READABLE-OBJECT" "READTABLE" + "PRINT-OBJECT" "READTABLE-CASE" + "PRINT-UNREADABLE-OBJECT" "READTABLEP" + "PROBE-FILE" "REAL" + "PROCLAIM" "REALP" + "PROG" "REALPART" + "PROG*" "REDUCE" + "PROG1" "REINITIALIZE-INSTANCE" + "PROG2" "REM" + "PROGN" "REMF" + "PROGRAM-ERROR" "REMHASH" + "PROGV" "REMOVE" + "PROVIDE" "REMOVE-DUPLICATES" + "PSETF" "REMOVE-IF" + "PSETQ" "REMOVE-IF-NOT" + "PUSH" "REMOVE-METHOD" + "PUSHNEW" "REMPROP" + "QUOTE" "RENAME-FILE" + "RANDOM" "RENAME-PACKAGE" + "RANDOM-STATE" "REPLACE" + "RANDOM-STATE-P" "REQUIRE" + "RASSOC" "REST" + "RASSOC-IF" "RESTART" + "RASSOC-IF-NOT" "RESTART-BIND" + "RATIO" "RESTART-CASE" + "RATIONAL" "RESTART-NAME" + "RATIONALIZE" "RETURN" + "RATIONALP" "RETURN-FROM" + "READ" "REVAPPEND" + "READ-BYTE" "REVERSE" + + ;; from figure 1-13: + "ROOM" "SIMPLE-BIT-VECTOR" + "ROTATEF" "SIMPLE-BIT-VECTOR-P" + "ROUND" "SIMPLE-CONDITION" + "ROW-MAJOR-AREF" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" + "RPLACA" "SIMPLE-CONDITION-FORMAT-CONTROL" + "RPLACD" "SIMPLE-ERROR" + "SAFETY" "SIMPLE-STRING" + "SATISFIES" "SIMPLE-STRING-P" + "SBIT" "SIMPLE-TYPE-ERROR" + "SCALE-FLOAT" "SIMPLE-VECTOR" + "SCHAR" "SIMPLE-VECTOR-P" + "SEARCH" "SIMPLE-WARNING" + "SECOND" "SIN" + "SEQUENCE" "SINGLE-FLOAT" + "SERIOUS-CONDITION" "SINGLE-FLOAT-EPSILON" + "SET" "SINGLE-FLOAT-NEGATIVE-EPSILON" + "SET-DIFFERENCE" "SINH" + "SET-DISPATCH-MACRO-CHARACTER" "SIXTH" + "SET-EXCLUSIVE-OR" "SLEEP" + "SET-MACRO-CHARACTER" "SLOT-BOUNDP" + "SET-PPRINT-DISPATCH" "SLOT-EXISTS-P" + "SET-SYNTAX-FROM-CHAR" "SLOT-MAKUNBOUND" + "SETF" "SLOT-MISSING" + "SETQ" "SLOT-UNBOUND" + "SEVENTH" "SLOT-VALUE" + "SHADOW" "SOFTWARE-TYPE" + "SHADOWING-IMPORT" "SOFTWARE-VERSION" + "SHARED-INITIALIZE" "SOME" + "SHIFTF" "SORT" + "SHORT-FLOAT" "SPACE" + "SHORT-FLOAT-EPSILON" "SPECIAL" + "SHORT-FLOAT-NEGATIVE-EPSILON" "SPECIAL-OPERATOR-P" + "SHORT-SITE-NAME" "SPEED" + "SIGNAL" "SQRT" + "SIGNED-BYTE" "STABLE-SORT" + "SIGNUM" "STANDARD" + "SIMPLE-ARRAY" "STANDARD-CHAR" + "SIMPLE-BASE-STRING" "STANDARD-CHAR-P" + + ;; from figure 1-14: + "STANDARD-CLASS" "SUBLIS" + "STANDARD-GENERIC-FUNCTION" "SUBSEQ" + "STANDARD-METHOD" "SUBSETP" + "STANDARD-OBJECT" "SUBST" + "STEP" "SUBST-IF" + "STORAGE-CONDITION" "SUBST-IF-NOT" + "STORE-VALUE" "SUBSTITUTE" + "STREAM" "SUBSTITUTE-IF" + "STREAM-ELEMENT-TYPE" "SUBSTITUTE-IF-NOT" + "STREAM-ERROR" "SUBTYPEP" + "STREAM-ERROR-STREAM" "SVREF" + "STREAM-EXTERNAL-FORMAT" "SXHASH" + "STREAMP" "SYMBOL" + "STRING" "SYMBOL-FUNCTION" + "STRING-CAPITALIZE" "SYMBOL-MACROLET" + "STRING-DOWNCASE" "SYMBOL-NAME" + "STRING-EQUAL" "SYMBOL-PACKAGE" + "STRING-GREATERP" "SYMBOL-PLIST" + "STRING-LEFT-TRIM" "SYMBOL-VALUE" + "STRING-LESSP" "SYMBOLP" + "STRING-NOT-EQUAL" "SYNONYM-STREAM" + "STRING-NOT-GREATERP" "SYNONYM-STREAM-SYMBOL" + "STRING-NOT-LESSP" "T" + "STRING-RIGHT-TRIM" "TAGBODY" + "STRING-STREAM" "TAILP" + "STRING-TRIM" "TAN" + "STRING-UPCASE" "TANH" + "STRING/=" "TENTH" + "STRING<" "TERPRI" + "STRING<=" "THE" + "STRING=" "THIRD" + "STRING>" "THROW" + "STRING>=" "TIME" + "STRINGP" "TRACE" + "STRUCTURE" "TRANSLATE-LOGICAL-PATHNAME" + "STRUCTURE-CLASS" "TRANSLATE-PATHNAME" + "STRUCTURE-OBJECT" "TREE-EQUAL" + "STYLE-WARNING" "TRUENAME" + + ;; from figure 1-15: + "TRUNCATE" "VALUES-LIST" + "TWO-WAY-STREAM" "VARIABLE" + "TWO-WAY-STREAM-INPUT-STREAM" "VECTOR" + "TWO-WAY-STREAM-OUTPUT-STREAM" "VECTOR-POP" + "TYPE" "VECTOR-PUSH" + "TYPE-ERROR" "VECTOR-PUSH-EXTEND" + "TYPE-ERROR-DATUM" "VECTORP" + "TYPE-ERROR-EXPECTED-TYPE" "WARN" + "TYPE-OF" "WARNING" + "TYPECASE" "WHEN" + "TYPEP" "WILD-PATHNAME-P" + "UNBOUND-SLOT" "WITH-ACCESSORS" + "UNBOUND-SLOT-INSTANCE" "WITH-COMPILATION-UNIT" + "UNBOUND-VARIABLE" "WITH-CONDITION-RESTARTS" + "UNDEFINED-FUNCTION" "WITH-HASH-TABLE-ITERATOR" + "UNEXPORT" "WITH-INPUT-FROM-STRING" + "UNINTERN" "WITH-OPEN-FILE" + "UNION" "WITH-OPEN-STREAM" + "UNLESS" "WITH-OUTPUT-TO-STRING" + "UNREAD-CHAR" "WITH-PACKAGE-ITERATOR" + "UNSIGNED-BYTE" "WITH-SIMPLE-RESTART" + "UNTRACE" "WITH-SLOTS" + "UNUSE-PACKAGE" "WITH-STANDARD-IO-SYNTAX" + "UNWIND-PROTECT" "WRITE" + "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "WRITE-BYTE" + "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WRITE-CHAR" + "UPGRADED-ARRAY-ELEMENT-TYPE" "WRITE-LINE" + "UPGRADED-COMPLEX-PART-TYPE" "WRITE-SEQUENCE" + "UPPER-CASE-P" "WRITE-STRING" + "USE-PACKAGE" "WRITE-TO-STRING" + "USE-VALUE" "Y-OR-N-P" + "USER-HOMEDIR-PATHNAME" "YES-OR-NO-P" + "VALUES" "ZEROP") diff -Nru sbcl-2.1.1/src/cold/compile-cold-sbcl.lisp sbcl-2.1.11/src/cold/compile-cold-sbcl.lisp --- sbcl-2.1.1/src/cold/compile-cold-sbcl.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/compile-cold-sbcl.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,8 +13,17 @@ (in-package "SB-COLD") +;;; FIXME: I think it's a mistake that we load muffler twice in +;;; make-host-2 (once for the host, once for XC), because the host +;;; should produce no new warnings, and because it's really hard +;;; to think straight when you figure that we're using the host's +;;; SIGNAL and type system but mixing it with our types. +;;; We can just bake in some behavior to the cross-compiler never to warn +;;; about sh*t that we think isn't warning-worthy. +;;; (i.e. do it in source code using #[-+]sb-xc-host). +;;; The target compiler will still get everything as usual. (let ((*features* (cons :sb-xc *features*))) - (load "src/cold/muffler.lisp")) + (load (sb-cold:find-bootstrap-file "^muffler"))) ;;; Ordinarily the types carried around as "handled conditions" while compiling ;;; have been parsed into internal CTYPE objects. However, using parsed objects diff -Nru sbcl-2.1.1/src/cold/defun-load-or-cload-xcompiler.lisp sbcl-2.1.11/src/cold/defun-load-or-cload-xcompiler.lisp --- sbcl-2.1.1/src/cold/defun-load-or-cload-xcompiler.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/defun-load-or-cload-xcompiler.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -97,6 +97,10 @@ (sb-cold::exit-process 1))))) (format t "~&; Parallel build: Skipping fasl load~%")) +;;; Read the version file once and once only, +;;; or not at all if you've otherwise defined this. +(defvar *target-sbcl-version* (read-from-file "version.lisp-expr")) + ;;; Either load or compile-then-load the cross-compiler into the ;;; cross-compilation host Common Lisp. (defun load-or-cload-xcompiler (load-or-cload-stem) @@ -113,6 +117,8 @@ (if (and (make-host-1-parallelism) (eq load-or-cload-stem #'host-cload-stem)) (progn + ;; FIXME: muffler not working in forked children? + (setq *fail-on-warnings* nil) ;; Multiprocess build uses the in-memory math ops cache but not ;; the persistent cache file because we don't need each child ;; to be forced to read the file. Moreover, newly inserted values @@ -135,6 +141,8 @@ (with-math-journal (do-stems-and-flags (stem flags 1) (unless (find :not-host flags) + ;; Enforce naming convention: target-* files are not for make-host-1 + (assert (not (search "code/target-" stem))) (funcall load-or-cload-stem stem flags) (when (member :sb-show sb-xc:*features*) (funcall 'warn-when-cl-snapshot-diff *cl-snapshot*)))))) diff -Nru sbcl-2.1.1/src/cold/muffler.lisp sbcl-2.1.11/src/cold/muffler.lisp --- sbcl-2.1.1/src/cold/muffler.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/muffler.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -26,7 +26,15 @@ (and (typep (car args) '(cons string)) (search "forced to do" (caar args))))))))) +#+sbcl +(defvar *optional-and-key-warning-condition* + (find-symbol "&OPTIONAL-AND-&KEY-IN-LAMBDA-LIST" "SB-KERNEL")) + (defun optional+key-style-warning-p (condition) + #+sbcl + (when *optional-and-key-warning-condition* + (return-from optional+key-style-warning-p + (typep condition *optional-and-key-warning-condition*))) (and (typep condition '(and simple-condition style-warning)) (let ((fc (simple-condition-format-control condition))) (and (stringp fc) diff -Nru sbcl-2.1.1/src/cold/package-data-list.lisp-expr sbcl-2.1.11/src/cold/package-data-list.lisp-expr --- sbcl-2.1.1/src/cold/package-data-list.lisp-expr 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/cold/package-data-list.lisp-expr 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,3562 @@ +;;;; -*- Lisp -*- + +;;;; the specifications of target packages, except for a few things +;;;; which are handled elsewhere by other mechanisms: +;;;; * some SHADOWing and nickname hackery; +;;;; * the standard, non-SBCL-specific packages COMMON-LISP, +;;;; COMMON-LISP-USER, and KEYWORD. +;;;; + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +;;;; KLUDGE: To make it easier for emacs to autoindent this file nicely +;;;; (which prevents spurious conflicts in CVS) each longish list should +;;;; have only one string on the first line. Silly, but there you go. + +;;;; NOTE: +;;;; All uses of #+ and #- reader macros within this file refer to +;;;; the chosen target features, and not CL:*FEATURES*, but +;;;; it is generally not necessary to use reader conditionals +;;;; within this file. If A-NICE-FUNCTION is external in SB-KERNEL +;;;; but not defined for a particular backend, it will not get +;;;; interned during cold load, and hence will not exist in the target. +;;;; This is exactly as desired - it is not necessary for the writer +;;;; of architecture-specific code to clutter up the list of package +;;;; definitions to avoid exporting some stuff. You just export what you +;;;; need, and genesis will do the right thing. Most of the pre-existing +;;;; conditionals are historical baggage, and should be removed. +;;;; EXCEPTION: packages whose symbols are created mainly during +;;;; warm load might have a reason to use reader conditionals. +;;;; For those packages, all symbols listed here are interned during +;;;; genesis, since otherwise the symbols would all disappear, +;;;; and then warm load would intern them as internals, not externals. +;;;; This list of exceptional packages can be found in the +;;;; definition of the FINISH-SYMBOLS function. + +(#s(sb-cold:package-data + :name "SB-ALIEN" + :doc "public: the ALIEN foreign function interface (If you're +porting CMU CL code, note that this package corresponds roughly to a union +of the packages ALIEN and C-CALL at the time of the SBCL fork. SB-C-CALL +is a deprecated nickname to help ease the transition from older versions +of SBCL which maintained the CMU-CL-style split into two packages.)" + :use ("CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-ALIEN-INTERNALS") + :reexport ("ARRAY" + "BOOLEAN" "CHAR" "DOUBLE-FLOAT" + "FLOAT" "FUNCTION" "INTEGER" "LONG-FLOAT" + "SINGLE-FLOAT" + ;; FIXME: Do we really want to reexport + ;; SYSTEM-AREA-POINTER here? Why? + "SYSTEM-AREA-POINTER" + "UNION" "VALUES" "*") + :export ("ADDR" + "ALIEN" + "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE" + "CAST" "C-STRING" + "DEFINE-ALIEN-ROUTINE" "DEFINE-ALIEN-TYPE" "DEFINE-ALIEN-VARIABLE" + "DEREF" "DOUBLE" + "ENUM" "EXTERN-ALIEN" + "FREE-ALIEN" + "GET-ERRNO" + "INT" + "LOAD-1-FOREIGN" "LOAD-FOREIGN" "LOAD-SHARED-OBJECT" "LONG" "LONG-LONG" + "MAKE-ALIEN" + "MAKE-ALIEN-STRING" + "NULL-ALIEN" + "OFF-T" + "SAP-ALIEN" "SHORT" "SIGNED" + "SIZE-T" "SSIZE-T" + "SLOT" "STRUCT" + "UNDEFINED-ALIEN-ERROR" + "UNLOAD-SHARED-OBJECT" + "UNSIGNED" + "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-LONG-LONG" "UNSIGNED-SHORT" + "UTF8-STRING" + "VOID" + "WITH-ALIEN")) + + #s(sb-cold:package-data + :name "SB-ALIEN-INTERNALS" + :doc "private: stuff for implementing ALIENs and friends" + :use ("CL") + :export ("%ALIEN-VALUE" + "%CAST" + "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR" + "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN" + "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT" + "%SLOT-ADDR" "*SAVED-FP*" "*VALUES-TYPE-OKAY*" + "ALIEN-ARRAY-TYPE" + "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE" + "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P" + "ALIEN-CALLBACK" + "ALIEN-CALLBACK-ACCESSOR-FORM" + "ALIEN-CALLBACK-ASSEMBLER-WRAPPER" + "ALIEN-DOUBLE-FLOAT-TYPE" "ALIEN-DOUBLE-FLOAT-TYPE-P" + "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FLOAT-TYPE" + "ALIEN-FLOAT-TYPE-P" "ALIEN-FUN-TYPE" + "ALIEN-FUN-TYPE-ARG-TYPES" "ALIEN-FUN-TYPE-P" + "ALIEN-FUN-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE" + "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED" + "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P" + "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P" + "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD" + "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET" + "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE" + "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS" + "ALIEN-RECORD-TYPE-P" "ALIEN-SINGLE-FLOAT-TYPE" + "ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE" + "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS" + "ALIEN-TYPE-P" "ALIEN-TYPEP" + "ALIEN-VALUE" + "ALIEN-VALUE-TYPE" + "ALIEN-VALUE-TYPEP" + "ALIEN-VALUE-SAP" "ALIEN-VALUE-P" + "ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P" + "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "ALIEN-VOID-TYPE-P" + "COMPUTE-ALIEN-REP-TYPE" "COMPUTE-DEPORT-ALLOC-LAMBDA" + "COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA" + "COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE" + "COMPUTE-NATURALIZE-LAMBDA" "DEFINE-ALIEN-TYPE-CLASS" + "DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR" + "DEPORT" "DEPORT-ALLOC" + "ENTER-ALIEN-CALLBACK" + "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM" + "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" + "INVOKE-WITH-SAVED-FP" "LOCAL-ALIEN" + "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P" + "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE" + "MAKE-ALIEN-FUN-TYPE" "MAKE-ALIEN-POINTER-TYPE" + "MAYBE-WITH-PINNED-OBJECTS" + "MAKE-LOCAL-ALIEN" "NATURALIZE" + "NOTE-LOCAL-ALIEN-TYPE" + "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE")) + + #s(sb-cold:package-data + :name "SB-ASSEM" + :doc "private: the assembler, used by the compiler" + :use ("CL" "SB-EXT" "SB-INT") + :export ("ASSEMBLY-UNIT" + "ASSEMBLY-UNIT-BITS" + "+INST-ALIGNMENT-BYTES+" + + "ASSEM-SCHEDULER-P" + "+ASSEM-MAX-LOCATIONS+" + + "*ASMSTREAM*" "MAKE-ASMSTREAM" + "ASMSTREAM-DATA-SECTION" + "ASMSTREAM-CODE-SECTION" + "ASMSTREAM-ELSEWHERE-SECTION" + "ASMSTREAM-ELSEWHERE-LABEL" + "ASMSTREAM-CONSTANT-TABLE" + "ASMSTREAM-CONSTANT-VECTOR" + "APPEND-SECTIONS" "ASSEMBLE-SECTIONS" + "EMIT" ".ALIGN" ".BYTE" ".LISPWORD" ".SKIP" + ".COVERAGE-MARK" ".COMMENT" + "EMIT-ALIGNMENT" "EMIT-BYTE" "EMIT-BACK-PATCH" + "EMIT-CHOOSER" "DEFINE-BITFIELD-EMITTER" + "DEFINE-INSTRUCTION" "DEFINE-INSTRUCTION-MACRO" + "EMIT-POSTIT" + "ANY-ALIGNMENT-BETWEEN-P" + + "MAKE-SEGMENT" "SEGMENT-ORIGIN" "ASSEMBLE" + "SEGMENT-BUFFER" + "SEGMENT-ENCODER-STATE" + "SEGMENT-HEADER-SKEW" + "INST" "INST*" "LABEL" "LABEL-P" "GEN-LABEL" + "EMIT-LABEL" "LABEL-POSITION" "LABEL-USEDP" + "FINALIZE-SEGMENT" + "SEGMENT-CONTENTS-AS-VECTOR" "WRITE-SEGMENT-CONTENTS" + "READS" "WRITES" "SEGMENT" + "WITHOUT-SCHEDULING" + "VARIABLE-LENGTH" + "SEGMENT-COLLECT-DYNAMIC-STATISTICS" + "SECTION-START" + "STMT-LABELS" "STMT-MNEMONIC" "STMT-OPERANDS" + "STMT-PLIST" + "STMT-PREV" "STMT-NEXT" + "ADD-STMT-LABELS" "DELETE-STMT" + "LABELED-STATEMENT-P" + "DEFPATTERN" + + ;; FIXME: These are in the SB-ASSEM package now, but + ;; (left over from CMU CL) are defined in files which + ;; are IN-PACKAGE SB-C. It would probably be cleaner + ;; to move at least most of them to files which are + ;; IN-PACKAGE SB-ASSEM. + "BRANCH" "FLUSHABLE")) + + #s(sb-cold:package-data + :name "SB-BIGNUM" + :doc "private: bignum implementation" + :use ("CL" "SB-KERNEL" "SB-INT" "SB-EXT" "SB-ALIEN" "SB-SYS") + :export ("%ADD-WITH-CARRY" + "%ALLOCATE-BIGNUM" "%ASHL" "%ASHR" + "%BIGNUM-LENGTH" "%BIGNUM-REF" "%BIGNUM-REF-WITH-OFFSET" + "%BIGNUM-SET" #+bignum-assertions "%%BIGNUM-SET" + "%BIGNUM-SET-LENGTH" "%DIGIT-0-OR-PLUSP" + "%DIGIT-LOGICAL-SHIFT-RIGHT" + "%FIXNUM-DIGIT-WITH-CORRECT-SIGN" "%FIXNUM-TO-DIGIT" + "%BIGFLOOR" "%LOGAND" "%LOGIOR" "%LOGNOT" "%LOGXOR" + "%MULTIPLY" "%MULTIPLY-AND-ADD" + "%SUBTRACT-WITH-BORROW" "ADD-BIGNUMS" + "BIGNUM-ASHIFT-LEFT" "BIGNUM-ASHIFT-LEFT-FIXNUM" + "BIGNUM-ASHIFT-RIGHT" + "BIGNUM-COMPARE" + "BIGNUM-ELEMENT-TYPE" "BIGNUM-GCD" "BIGNUM-INDEX" + "BIGNUM-LENGTH" + "BIGNUM-INTEGER-LENGTH" + "BIGNUM-LOGBITP" + "BIGNUM-LOGCOUNT" "BIGNUM-LOGICAL-AND" + "BIGNUM-LOGICAL-IOR" "BIGNUM-LOGICAL-NOT" + "BIGNUM-LOGICAL-XOR" "BIGNUM-PLUS-P" + "BIGNUM-TO-FLOAT" "BIGNUM-TRUNCATE" + "MAKE-SMALL-BIGNUM" + "MULTIPLY-BIGNUM-AND-FIXNUM" "MULTIPLY-BIGNUMS" + "MULTIPLY-FIXNUMS" "NEGATE-BIGNUM" + "%RANDOM-BIGNUM" "SUBTRACT-BIGNUM" "SXHASH-BIGNUM")) + + #s(sb-cold:package-data + :name "SB-C" + :doc "private: implementation of the compiler" + ;; (It seems strange to have the compiler USE SB-ALIEN-INTERNALS, + ;; but the point seems to be to be able to express things like + ;; SB-C:DEFTRANSFORM SB-ALIEN-INTERNALS:MAKE-LOCAL-ALIEN without + ;; having to use a bunch of package prefixes, by putting them + ;; in the SB-C package. Maybe it'd be tidier to define an SB-ALIEN-COMP + ;; package for this? But it seems like a fairly low priority.) + ;; (Probably the same considerations also explain why BIGNUM is + ;;in the USE list.) + :use ("CL" "SB-ALIEN-INTERNALS" "SB-ALIEN" "SB-ASSEM" "SB-BIGNUM" + #+sb-dyncount "SB-DYNCOUNT" "SB-EXT" "SB-FASL" "SB-INT" + "SB-KERNEL" "SB-SYS") + ;; "flushable" is an assembly instruction attribute and a fun-info attribute. + ;; But why do we need SLOT re-exported? + :reexport ("SLOT" "FLUSHABLE") + :export ("%ALIEN-FUNCALL" + "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "%UNWIND" + "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" + "%UNWIND-PROTECT-BREAKUP" + + "*BACKEND-BYTE-ORDER*" + "+BACKEND-INTERNAL-ERRORS+" "+BACKEND-PAGE-BYTES+" + "*BACKEND-REGISTER-SAVE-PENALTY*" + "*BACKEND-SBS*" ; storage bases + "*BACKEND-SC-NAMES*" "*BACKEND-SC-NUMBERS*" + "*BACKEND-SUBFEATURES*" + "*BACKEND-T-PRIMITIVE-TYPE*" + + "*COMPILATION*" + "*COMPILE-TO-MEMORY-SPACE*" + "*LEXENV*" + "*SUPPRESS-VALUES-DECLARATION*" + + #+x86 "SET-FPU-WORD-FOR-C" + #+x86 "SET-FPU-WORD-FOR-LISP" + "ALIGN-STACK-POINTER" + "ALIEN-FUNCALL-SAVES-FP-AND-PC" + "ALLOC-ALIEN-STACK-SPACE" "ALLOC-NUMBER-STACK-SPACE" + "ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME" + "ALLOCATE-FULL-CALL-FRAME" + "ALWAYS-TRANSLATABLE" + "ANCESTOR-FRAME-REF" "ANCESTOR-FRAME-SET" + "ANY" "ASSEMBLE-FILE" + "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION" + "ATTRIBUTES=" + "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-VARIABLE" + "CALL-OUT" "CALL-OUT-NAMED" + "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN" + "CATCH-BLOCK" "UNWIND-BLOCK" + "CLOSURE-INIT" "CLOSURE-REF" "CLOSURE-INIT-FROM-FP" + "COMPARE-AND-SWAP-SLOT" + "COMPILE-IN-LEXENV" + "COMPILE-FILES" + "COMPILED-DEBUG-FUN-FORM-NUMBER" + "%COMPILER-DEFUN" "COMPILER-ERROR" "FATAL-COMPILER-ERROR" + "COMPILER-NOTIFY" + "COMPILER-STYLE-WARN" "COMPILER-WARN" + "COMPONENT" "COMPONENT-HEADER-LENGTH" + "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUN" + "COMPUTE-OLD-NFP" "COPY-MORE-ARG" + "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN" + "CURRENT-STACK-POINTER" + "*ALIEN-STACK-POINTER*" + "CURRENT-NSP" "SET-NSP" + "DEALLOC-NUMBER-STACK-SPACE" + "DEBUG-CATCH-TAG" + "DEF-IR1-TRANSLATOR" + "!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS" + "DEFINE-SOURCE-TRANSFORM" + "DEFINITION-SOURCE-LOCATION" + "DEFINITION-SOURCE-LOCATION-NAMESTRING" + "DEFINITION-SOURCE-LOCATION-TOPLEVEL-FORM-NUMBER" + "DEFINITION-SOURCE-LOCATION-FORM-NUMBER" + "DEFINITION-SOURCE-LOCATION-PLIST" + "DEFINE-MODULAR-FUN" + "DEFINE-MOVE-FUN" + "DEFINE-MOVE-VOP" "!DEFINE-STORAGE-BASES" + "!DEFINE-STORAGE-CLASS" "DEFINE-VOP" + "DEFKNOWN" "DEFOPTIMIZER" + "DEFTRANSFORM" "DERIVE-TYPE" + "DIS" + "DO-FORMS-FROM-INFO" + "EMIT-BLOCK-HEADER" + "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN" + "FAST-SYMBOL-VALUE" + "FAST-SYMBOL-GLOBAL-VALUE" + "FIXUP-NOTE-KIND" + "FIXUP-NOTE-FIXUP" + "FIXUP-NOTE-POSITION" + "FOLDABLE" + "FORCE-TN-TO-STACK" + "FUN-INFO-DERIVE-TYPE" "FUN-INFO-IR2-CONVERT" + "FUN-INFO-LTN-ANNOTATE" "FUN-INFO-OPTIMIZER" + "GET-TOPLEVELISH-FILE-INFO" + "HALT" + "IF-EQ" + "CONSTANT-LVAR-P" + "CONSTANT-TN-P" + "INSERT-SAFEPOINTS" + "COMPILER-MACRO-APPLICATION-MISSED-WARNING" + "INLINING-DEPENDENCY-FAILURE" + "INSERT-ARRAY-BOUNDS-CHECKS" + "INSERT-STEP-CONDITIONS" + "INSTRUMENT-CONSING" + "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT" + "IR2-ENVIRONMENT-NUMBER-STACK-P" + "KNOWN-CALL-LOCAL" "KNOWN-RETURN" + "LAMBDA-VAR-IGNOREP" + "LAMBDA-WITH-LEXENV" "LEXENV-FIND" + "LOCATION=" "LTN-ANNOTATE" + "LVAR-VALUE" + "MACRO-POLICY-DECLS" + "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK" + "MAKE-CLOSURE" "MAKE-CONSTANT-TN" + "MAKE-FIXUP-NOTE" + "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN" + "MAKE-RANDOM-TN" + "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" + "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK" + "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTIFY" + "MAYBE-INLINE-SYNTACTIC-CLOSURE" + "MSAN-UNPOISON" + "MOVABLE" "MOVE" "MULTIPLE-CALL" + "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED" + "MULTIPLE-CALL-VARIABLE" + "%%NIP-VALUES" + "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" "NLX-ENTRY-SINGLE" + "NODE-STACK-ALLOCATE-P" + "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" + "NOTE-THIS-LOCATION" "*LOCATION-CONTEXT*" + "MAKE-RESTART-LOCATION" + "OPTIMIZER" + "PACK-CODE-FIXUP-LOCS" + "PARSE-EVAL-WHEN-SITUATIONS" + "POLICY" + "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF" + "PRIMITIVE-TYPE-OR-LOSE" + "PRIMITIVE-TYPE-NAME" + "PRIMITIVE-TYPE-INDIRECT-CELL-TYPE" + "PROCLAIM-FTYPE" "PROCLAIM-TYPE" + "PUSH-VALUES" + "READ-PACKED-BIT-VECTOR" + "READ-VAR-INTEGER" "READ-VAR-INTEGERF" + "SAP-READ-VAR-INTEGER" "SAP-READ-VAR-INTEGERF" + "READ-VAR-STRING" + "REFERENCE-TN" "REFERENCE-TN-LIST" + "REGISTER-INLINE-CONSTANT" + "RESET-STACK-POINTER" "RESTORE-DYNAMIC-STATE" + "RETURN-MULTIPLE" "SAVE-DYNAMIC-STATE" "STORAGE-BASE" + "SB-ALLOCATED-SIZE" "SB-NAME" "SB-OR-LOSE" + "STORAGE-CLASS" "SC-CASE" "SC-OPERAND-SIZE" + "SC-IS" "SC-NAME" "SC-NUMBER" "SC-SB" + "SC-OR-LOSE" "SC-NUMBER-OR-LOSE" + "SC+OFFSET" "MAKE-SC+OFFSET" "SC+OFFSET-OFFSET" "SC+OFFSET-SCN" + "SET-UNWIND-PROTECT" + "SETUP-CLOSURE-ENVIRONMENT" + "SOURCE-LOCATION" + "SPECIFY-SAVE-TN" + "STATIC-CALL-NAMED" "STATIC-MULTIPLE-CALL-NAMED" "STATIC-TAIL-CALL-NAMED" + "STORE-COVERAGE-DATA" "STORE-SOURCE-FORM" + "TAIL-CALL" "TAIL-CALL-NAMED" + "TAIL-CALL-VARIABLE" "TEMPLATE-OR-LOSE" + "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN" + "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET" + "TN-REF-TN" "TN-REF-TYPE" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" + "TN-REF-MEMORY-ACCESS" + "TN-KIND" "TN-VALUE" + "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-N" "UNBIND-TO-HERE" + "UNSAFE" "UNSAFELY-FLUSHABLE" "UNWIND" "UWP-ENTRY" + "UNPACK-CODE-FIXUP-LOCS" + "VERIFY-ARG-COUNT" "WRITE-PACKED-BIT-VECTOR" + "WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME" + "XEP-SETUP-SP" + "LABEL-ID" "FIXUP" "FIXUP-FLAVOR" "FIXUP-NAME" "FIXUP-OFFSET" + "FIXUP-P" "MAKE-FIXUP" + "DEF-ALLOC" + "VAR-ALLOC" + "SAFE-FDEFN-FUN" + "NOTE-FIXUP" + "DEF-CASSER" + "DEF-REFFER" + "EMIT-CONSTANT" + "EMIT-NOP" + "DEF-SETTER" + "FIXED-ALLOC" + "MAKE-FUNCALLABLE-INSTANCE-TRAMP" + "RETURN-SINGLE" + "NOTE-NEXT-INSTRUCTION" + "SET-SLOT" + "LOCATION-NUMBER" + "*COMPONENT-BEING-COMPILED*" + "BLOCK-NUMBER" + "IR2-BLOCK-BLOCK" + "VOP-BLOCK" + "VOP-NEXT" "NEXT-VOP-IS" "REPLACE-VOPS" + "VOP-NAME" "VOP-CODEGEN-INFO" + + "IMMEDIATE-CONSTANT-SC" + "BOXED-IMMEDIATE-SC-P" + "COMBINATION-IMPLEMENTATION-STYLE" + "CONVERT-CONDITIONAL-MOVE-P" + "LOCATION-PRINT-NAME" + "MAKE-CALL-OUT-TNS" + "STANDARD-ARG-LOCATION" + "STANDARD-ARG-LOCATION-SC" + "ARG-COUNT-SC" + "CLOSURE-SC" + "MAKE-RETURN-PC-PASSING-LOCATION" + "MAKE-OLD-FP-PASSING-LOCATION" + "MAKE-OLD-FP-SAVE-LOCATION" + "RETURN-PC-PASSING-OFFSET" + "OLD-FP-PASSING-OFFSET" + "MAKE-RETURN-PC-SAVE-LOCATION" + "MAKE-ARG-COUNT-LOCATION" + "MAKE-NFP-TN" + "MAKE-NUMBER-STACK-POINTER-TN" + "MAKE-UNKNOWN-VALUES-LOCATIONS" + "MAKE-NLX-SP-TN" + "MAKE-DYNAMIC-STATE-TNS" + "MAKE-NLX-ENTRY-ARG-START-LOCATION" + "GENERATE-CALL-SEQUENCE" + "GENERATE-RETURN-SEQUENCE" + "WITH-COMPILER-ERROR-RESIGNALLING" + "XDEFUN" ; extended defun for defstruct + + "BRANCH-IF" "MULTIWAY-BRANCH-IF-EQ" + + ;; for SB-COVER + "*CODE-COVERAGE-INFO*" "CODE-COVERAGE-RECORD-MARKED" + "CLEAR-CODE-COVERAGE" "RESET-CODE-COVERAGE" + "+CODE-COVERAGE-UNMARKED+" + ;; for SB-INTROSPECT + "MAP-PACKED-XREF-DATA" "MAP-SIMPLE-FUNS" + + "DO-BLOCKS" "DO-BLOCKS-BACKWARDS" + "DO-NODES" "DO-NODES-BACKWARDS" + "DO-IR2-BLOCKS")) + + #s(sb-cold:package-data + :name "SB-DEBUG" + :doc + "sorta public: Eventually this should become the debugger interface, with +basic stuff like BACKTRACE and ARG. For now, the actual supported interface +is still mixed indiscriminately with low-level internal implementation stuff +like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." + :use ("CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-KERNEL" "SB-DI") + :reexport ("*DEBUG-PRINT-VARIABLE-ALIST*") + :export ("*BACKTRACE-FRAME-COUNT*" + "*DEBUG-BEGINNER-HELP-P*" + "*DEBUG-CONDITION*" + "*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*" + "*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*" + "*METHOD-FRAME-STYLE*" + "*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*" + "ARG" + "INTERNAL-DEBUG" "VAR" + "*STACK-TOP-HINT*" + "*TRACE-ENCAPSULATE-DEFAULT*" + "FRAME-HAS-DEBUG-TAG-P" + "UNWIND-TO-FRAME-AND-CALL" + ;; Deprecated + "BACKTRACE" "BACKTRACE-AS-LIST" + ;; Replaced by + "PRINT-BACKTRACE" "LIST-BACKTRACE")) + + #s(sb-cold:package-data + :name "SB-DI" + :doc "private: primitives used to write debuggers" + :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL" "SB-SYS" "SB-VM") + :import-from (("SB-C" + "DEBUG-SOURCE-NAMESTRING" + "DEBUG-SOURCE-CREATED" + "MAKE-DEBUG-SOURCE" + "DEBUG-SOURCE" "DEBUG-SOURCE-P" + "CORE-DEBUG-SOURCE" "CORE-DEBUG-SOURCE-P" + "CORE-DEBUG-SOURCE-FORM")) + :reexport ("DEBUG-SOURCE-NAMESTRING" + "DEBUG-SOURCE-CREATED" + "DEBUG-SOURCE" "DEBUG-SOURCE-P") + :export ("ACTIVATE-BREAKPOINT" + "AMBIGUOUS-DEBUG-VARS" "AMBIGUOUS-VAR-NAME" "BREAKPOINT" + "BREAKPOINT-ACTIVE-P" "BREAKPOINT-HOOK-FUN" "BREAKPOINT-INFO" + "BREAKPOINT-KIND" "BREAKPOINT-P" "BREAKPOINT-WHAT" "CODE-LOCATION" + "CODE-LOCATION-DEBUG-BLOCK" "CODE-LOCATION-DEBUG-FUN" + "CODE-LOCATION-DEBUG-SOURCE" "CODE-LOCATION-FORM-NUMBER" + "CODE-LOCATION-P" "CODE-LOCATION-TOPLEVEL-FORM-OFFSET" + "CODE-LOCATION-CONTEXT" + "CODE-LOCATION-UNKNOWN-P" "CODE-LOCATION=" "DEACTIVATE-BREAKPOINT" + "DEBUG-BLOCK" "DEBUG-BLOCK-ELSEWHERE-P" "DEBUG-BLOCK-P" + "DEBUG-CONDITION" "DEBUG-ERROR" + "DEBUG-FUN" "DEBUG-FUN-FUN" "DEBUG-FUN-KIND" + "DEBUG-FUN-LAMBDA-LIST" "DEBUG-FUN-NAME" "DEBUG-FUN-CLOSURE-NAME" + "DEBUG-FUN-P" "DEBUG-FUN-START-LOCATION" + "DEBUG-FUN-SYMBOL-VARS" + "DEBUG-VAR" "DEBUG-VAR-ID" "DEBUG-VAR-INFO-AVAILABLE" + "DEBUG-VAR-SYMBOL-NAME" "DEBUG-VAR-P" "DEBUG-VAR-PACKAGE-NAME" + "DEBUG-VAR-SYMBOL" "DEBUG-VAR-VALID-VALUE" + "DEBUG-VAR-VALIDITY" "DEBUG-VAR-VALUE" + "DELETE-BREAKPOINT" + "DO-DEBUG-BLOCK-LOCATIONS" "DO-DEBUG-FUN-BLOCKS" + "DO-DEBUG-FUN-VARS" + "ERROR-CONTEXT" + "FORM-NUMBER-TRANSLATIONS" + "FRAME" "FRAME-CATCHES" "FRAME-CODE-LOCATION" + "FRAME-DEBUG-FUN" "FRAME-DOWN" + "FRAME-FUN-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP" + "GET-TOPLEVEL-FORM" + "REPLACE-FRAME-CATCH-TAG" + "FUN-DEBUG-FUN" "FUN-END-COOKIE-VALID-P" + "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE" + "LAMBDA-LIST-UNAVAILABLE" "MAKE-BREAKPOINT" "NO-DEBUG-BLOCKS" + "NO-DEBUG-FUN-RETURNS" "PREPROCESS-FOR-EVAL" + "EVAL-IN-FRAME" "RETURN-FROM-FRAME" "SOURCE-PATH-CONTEXT" + "TOP-FRAME" "UNHANDLED-DEBUG-CONDITION" + "UNKNOWN-DEBUG-VAR" + "CODE-LOCATION-KIND" "FLUSH-FRAMES-ABOVE")) + + #s(sb-cold:package-data + :name "SB-DISASSEM" + :doc "private: stuff related to the implementation of the disassembler" + :use ("CL" "SB-EXT" "SB-INT" "SB-SYS" "SB-KERNEL" "SB-DI") + :export ("*DISASSEM-NOTE-COLUMN*" "*DISASSEM-OPCODE-COLUMN-WIDTH*" + "*DISASSEM-LOCATION-COLUMN-WIDTH*" + "ALIGN" ;; prevent it from being removed, older Slime versions are using it + "ARG-VALUE" "DISASSEM-STATE" + "DISASSEMBLE-CODE-COMPONENT" + "DISASSEMBLE-FUN" "DISASSEMBLE-MEMORY" + "DISASSEMBLE-INSTRUCTION" + "DISASSEMBLE-SEGMENT" "DISASSEMBLE-SEGMENTS" + "DSTATE-BYTE-ORDER" + "DSTATE-GETPROP" + "DSTATE-SETPROP" + "DSTATE-SEGMENT-SAP" + "DSTATE-OPERANDS" + "FIND-INST" + "GET-CODE-SEGMENTS" "GET-FUN-SEGMENTS" + "GET-INST-SPACE" "HANDLE-BREAK-ARGS" + "LABEL-SEGMENTS" + "MAYBE-NOTE-ASSEMBLER-ROUTINE" + "MAYBE-NOTE-ASSOCIATED-STORAGE-REF" + "MAYBE-NOTE-NIL-INDEXED-OBJECT" + "MAYBE-NOTE-NIL-INDEXED-SYMBOL-SLOT-REF" + "MAYBE-NOTE-SINGLE-STORAGE-REF" + "MAYBE-NOTE-STATIC-SYMBOL" + "NOTE" + "NOTE-CODE-CONSTANT" + "OPERAND" + "PRIN1-QUOTED-SHORT" + "PRIN1-SHORT" "PRINT-BYTES" + "PRINT-CURRENT-ADDRESS" "PRINT-INST" + "PRINT-NOTES-AND-NEWLINE" + "SAP-REF-INT" + "SEG-CODE" "SEG-LENGTH" "SEGMENT" + "SIGN-EXTEND" + "MAKE-DSTATE" + "DEFINE-ARG-TYPE" + "READ-SIGNED-SUFFIX" + "MAKE-MEMORY-SEGMENT" + "MAKE-SEGMENT" "SEG-VIRTUAL-LOCATION" + "DCHUNK" "DCHUNK-ZERO" "*DEFAULT-DSTATE-HOOKS*" + "MAKE-CODE-SEGMENT" "MAKE-OFFS-HOOK" + "DSTATE-SEGMENT" "DSTATE-CUR-OFFS" + "PRINC16" "INSTRUCTION" "DEFINE-INSTRUCTION-FORMAT" + "DSTATE-NEXT-OFFS" + "SEG-SAP-MAKER" "DISASSEMBLE-ASSEM-SEGMENT" + "READ-SUFFIX" + "MAP-SEGMENT-INSTRUCTIONS" + "SET-LOCATION-PRINTING-RANGE" "MAKE-VECTOR-SEGMENT" + "DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR" + "SNARF-ERROR-JUNK")) + + #+sb-dyncount + #s(sb-cold:package-data + :name "SB-DYNCOUNT" + :doc "private: some somewhat-stale code for collecting runtime statistics" + :use ("CL" "SB-ALIEN-INTERNALS" "SB-ALIEN" "SB-BIGNUM" + "SB-EXT" "SB-INT" "SB-KERNEL" "SB-ASSEM" "SB-SYS") + :export ("*COLLECT-DYNAMIC-STATISTICS*" + "COUNT-ME" + "DYNCOUNT-INFO-COUNTS" "DYNCOUNT-INFO-COSTS" + "IR2-COMPONENT-DYNCOUNT-INFO" + "DYNCOUNT-INFO" "DYNCOUNT-INFO-P")) + + #s(sb-cold:package-data + :name "SB-FASL" + :doc "private: stuff related to FASL load/dump logic (and GENESIS)" + :use ("CL" "SB-ALIEN" "SB-ASSEM" "SB-BIGNUM" "SB-C" + "SB-EXT" "SB-INT" "SB-KERNEL" "SB-SYS") + :import-from (("SB-VM" "+FIXUP-KINDS+")) + :export ("*ASSEMBLER-ROUTINES*" + "GET-ASM-ROUTINE" + "+BACKEND-FASL-FILE-IMPLEMENTATION+" + "*FASL-FILE-TYPE*" + "CLOSE-FASL-OUTPUT" + "DUMP-ASSEMBLER-ROUTINES" + "DUMP-FOP" "DUMP-OBJECT" + "FASL-CONSTANT-ALREADY-DUMPED-P" + "+FASL-FILE-VERSION+" + "FASL-DUMP-COMPONENT" + "FASL-DUMP-LOAD-TIME-VALUE-LAMBDA" + "FASL-DUMP-TOPLEVEL-LAMBDA-CALL" + "FASL-NOTE-HANDLE-FOR-CONSTANT" + "FASL-OUTPUT" "FASL-OUTPUT-P" + "FASL-OUTPUT-ENTRY-TABLE" "FASL-OUTPUT-STREAM" + "FASL-NOTE-DUMPABLE-INSTANCE" + "LOAD-FORM-IS-DEFAULT-MLFSS-P" + "*!LOAD-TIME-VALUES*" + "OPEN-FASL-OUTPUT" + "*!COLD-DEFSYMBOLS*" + "*!COLD-TOPLEVELS*" + "COLD-CONS" "COLD-INTERN" "COLD-PUSH")) + + ;; This package is a grab bag for things which used to be internal + ;; symbols in package COMMON-LISP. Lots of these symbols are accessed + ;; with explicit SB-IMPL:: prefixes in the code. It would be nice to + ;; reduce the use of this practice, so if symbols from here which are + ;; accessed that way are found to belong more appropriately in an + ;; existing package (e.g. SB-KERNEL or SB-SYS or SB-EXT or SB-FASL), + ;; I (WHN 19990223) encourage maintainers to move them there.. + #s(sb-cold:package-data + :name "SB-IMPL" + :doc "private: a grab bag of implementation details" + :import-from (("SB-KERNEL" "*PACKAGE-NAMES*")) + :export ("FORMAT-MICROSECONDS" "FORMAT-MILLISECONDS" ; for ~/fmt/ + "PRINT-TYPE" "PRINT-TYPE-SPECIFIER" + "PRINT-LAMBDA-LIST" + ;; protect from tree shaker so we can test this function + "EXPAND-SYMBOL-CASE" + ;; symbols used by sb-simple-streams + "ANSI-STREAM-CLEAR-INPUT" + "ANSI-STREAM-LISTEN" + "ANSI-STREAM-READ-BYTE" "ANSI-STREAM-READ-CHAR" + "ANSI-STREAM-READ-CHAR-NO-HANG" "ANSI-STREAM-READ-LINE" + "ANSI-STREAM-READ-SEQUENCE" "ANSI-STREAM-PEEK-CHAR" + "ANSI-STREAM-UNREAD-CHAR" + "DISPATCH-TABLES" "CHARACTER-MACRO-HASH-TABLE" "CHARACTER-MACRO-ARRAY" + "TOKEN-DELIMITERP" "WHITESPACE[2]P" "WITH-READ-BUFFER" + ;; other + "%MAKUNBOUND") + :use ("CL" "SB-ALIEN" "SB-BIGNUM" "SB-DEBUG" "SB-EXT" + "SB-FASL" "SB-GRAY" "SB-INT" "SB-KERNEL" "SB-SYS")) + + #s(sb-cold:package-data + :name "SB-EXT" + :doc "public: miscellaneous supported extensions to the ANSI Lisp spec" + :use ("CL" "SB-ALIEN" "SB-INT" "SB-SYS" "SB-GRAY") + :export ( ;; Information about how the program was invoked is + ;; nonstandard but very useful. + "*POSIX-ARGV*" "*CORE-PATHNAME*" "*RUNTIME-PATHNAME*" + "POSIX-GETENV" "POSIX-ENVIRON" + + ;; Customizing initfile locations + "*USERINIT-PATHNAME-FUNCTION*" + "*SYSINIT-PATHNAME-FUNCTION*" + + "*DEFAULT-EXTERNAL-FORMAT*" + "*DEFAULT-C-STRING-EXTERNAL-FORMAT*" + + ;; Compare and Swap support + "CAS" + "COMPARE-AND-SWAP" + "DEFCAS" + "GET-CAS-EXPANSION" + + ;; Other atomic operations and types related to them + "ATOMIC-INCF" + "ATOMIC-DECF" + "ATOMIC-UPDATE" + "ATOMIC-PUSH" + "ATOMIC-POP" + "WORD" + "MOST-POSITIVE-WORD" + + ;; Not an atomic operation, but should be used with them + "SPIN-LOOP-HINT" + + ;; Waiting for arbitrary events. + "WAIT-FOR" + + ;; Time related things + "CALL-WITH-TIMING" + "GET-TIME-OF-DAY" + + ;; People have various good reasons to mess with the GC. + "HEAP-ALLOCATED-P" + "STACK-ALLOCATED-P" + "*AFTER-GC-HOOKS*" + "BYTES-CONSED-BETWEEN-GCS" + "GC" "GET-BYTES-CONSED" + "*GC-RUN-TIME*" + "PURIFY" + "DYNAMIC-SPACE-SIZE" + ;; Gencgc only, but symbols exist for manual building + ;; convenience on all platforms. + "GENERATION-AVERAGE-AGE" + "GENERATION-BYTES-ALLOCATED" + "GENERATION-BYTES-CONSED-BETWEEN-GCS" + "GENERATION-MINIMUM-AGE-BEFORE-GC" + "GENERATION-NUMBER-OF-GCS" + "GENERATION-NUMBER-OF-GCS-BEFORE-PROMOTION" + "GC-LOGFILE" + + ;; Stack allocation control + "*STACK-ALLOCATE-DYNAMIC-EXTENT*" + + ;; Customizing printing of compiler and debugger messages + "*COMPILER-PRINT-VARIABLE-ALIST*" + "*DEBUG-PRINT-VARIABLE-ALIST*" + "COMPILE-FILE-LINE" + "COMPILE-FILE-POSITION" + + ;; Hooks into init & save sequences + "*INIT-HOOKS*" "*SAVE-HOOKS*" "*EXIT-HOOKS*" + "*FORCIBLY-TERMINATE-THREADS-ON-EXIT*" + + ;; Controlling exiting other threads. + "*EXIT-TIMEOUT*" + + ;; There is no one right way to report progress on + ;; hairy compiles. + "*COMPILE-PROGRESS*" + + ;; The default behavior for block compilation. + "*BLOCK-COMPILE-DEFAULT*" + + ;; It can be handy to be able to evaluate expressions involving + ;; the thing under examination by CL:INSPECT. + "*INSPECTED*" + + ;; There is no one right way to do efficiency notes. + "*EFFICIENCY-NOTE-COST-THRESHOLD*" "*EFFICIENCY-NOTE-LIMIT*" + + ;; There's no one right way to report errors. + "*ENCLOSING-SOURCE-CUTOFF*" + "*UNDEFINED-WARNING-LIMIT*" + + ;; and for dedicated users who really want to customize + ;; error reporting, we have + "DEFINE-SOURCE-CONTEXT" + "WITH-CURRENT-SOURCE-FORM" + + ;; and given how many users dislike strict treatment of + ;; DEFCONSTANT, let's give them enough rope to escape by + "DEFCONSTANT-UNEQL" "DEFCONSTANT-UNEQL-NAME" + "DEFCONSTANT-UNEQL-NEW-VALUE" "DEFCONSTANT-UNEQL-OLD-VALUE" + + ;; global lexicals, access to global symbol values + "DEFGLOBAL" + "DEFINE-LOAD-TIME-GLOBAL" + "SYMBOL-GLOBAL-VALUE" + + "FILE-EXISTS" + "FILE-DOES-NOT-EXIST" + "DELETE-FILE-ERROR" + "SUPERSEDE" + "OVERWRITE" + "RENAME" + "CREATE" + "RETRY" + + ;; package extensions + ;; + ;; locks + "PACKAGE-LOCKED-P" + "LOCK-PACKAGE" + "UNLOCK-PACKAGE" + "PACKAGE-IMPLEMENTED-BY-LIST" + "PACKAGE-IMPLEMENTS-LIST" + "ADD-IMPLEMENTATION-PACKAGE" + "REMOVE-IMPLEMENTATION-PACKAGE" + "WITH-UNLOCKED-PACKAGES" + "PACKAGE-LOCK-VIOLATION" + "PACKAGE-LOCKED-ERROR" + "SYMBOL-PACKAGE-LOCKED-ERROR" + "PACKAGE-LOCKED-ERROR-SYMBOL" + "WITHOUT-PACKAGE-LOCKS" + "DISABLE-PACKAGE-LOCKS" + "ENABLE-PACKAGE-LOCKS" + ;; local nicknames + "ADD-PACKAGE-LOCAL-NICKNAME" + "REMOVE-PACKAGE-LOCAL-NICKNAME" + "PACKAGE-LOCAL-NICKNAMES" + "PACKAGE-LOCALLY-NICKNAMED-BY-LIST" + + "PACKAGE-DOES-NOT-EXIST" "READER-PACKAGE-DOES-NOT-EXIST" + ;; behaviour on DEFPACKAGE variance + "*ON-PACKAGE-VARIANCE*" + + ;; Custom conditions & condition accessors for users to handle. + "CODE-DELETION-NOTE" + "COMPILER-NOTE" + "IMPLICIT-GENERIC-FUNCTION-NAME" + "IMPLICIT-GENERIC-FUNCTION-WARNING" + "INVALID-FASL" + + "NAME-CONFLICT" "NAME-CONFLICT-FUNCTION" + "NAME-CONFLICT-DATUM" "NAME-CONFLICT-SYMBOLS" + "RESOLVE-CONFLICT" + + ;; Deprecation stuff + "DEPRECATED" ; declaration + "DEPRECATION-CONDITION" + "DEPRECATION-CONDITION-NAMESPACE" + "DEPRECATION-CONDITION-NAME" + "DEPRECATION-CONDITION-SOFTWARE" + "DEPRECATION-CONDITION-VERSION" + "DEPRECATION-CONDITION-REPLACEMENTS" + "DEPRECATION-CONDITION-RUNTIME-ERROR" + "EARLY-DEPRECATION-WARNING" + "LATE-DEPRECATION-WARNING" + "FINAL-DEPRECATION-WARNING" + "DEPRECATION-ERROR" ; condition and function + + "PRINT-UNREADABLY" + + ;; Readtable normalization control + "READTABLE-BASE-CHAR-PREFERENCE" + "READTABLE-NORMALIZATION" + + ;; and a mechanism for controlling same at compile time + "MUFFLE-CONDITIONS" "UNMUFFLE-CONDITIONS" + + ;; and one for controlling same at runtime + "*MUFFLED-WARNINGS*" + + ;; specification which print errors to ignore ala *break-on-signal* + "*SUPPRESS-PRINT-ERRORS*" + + ;; extended declarations.. + "ALWAYS-BOUND" "FREEZE-TYPE" "GLOBAL" "INHIBIT-WARNINGS" + "MAYBE-INLINE" "START-BLOCK" "END-BLOCK" + + ;; ..and variables to control compiler policy + "*INLINE-EXPANSION-LIMIT*" + "*DERIVE-FUNCTION-TYPES*" + + ;; ..and inspector of compiler policy + "DESCRIBE-COMPILER-POLICY" + "RESTRICT-COMPILER-POLICY" + "SET-MACRO-POLICY" + "FOLD-IDENTICAL-CODE" ; this is a verb, not a compiler policy + + ;; a special form for breaking out of our "declarations + ;; are assertions" default + "TRULY-THE" + + ;; Misc. array and vector tools. + "ARRAY-STORAGE-VECTOR" + "PRIMITIVE-OBJECT-SIZE" + + ;; This is something which must exist inside any Common + ;; Lisp implementation, and which someone writing a + ;; customized toplevel might well want. It seems perverse + ;; to hide it from them.. + "INTERACTIVE-EVAL" + + ;; Used by LOAD and EVAL-WHEN to pass toplevel indexes + ;; to compiler. + "EVAL-TLF" + + ;; weak pointers and finalization + "CANCEL-FINALIZATION" + "FINALIZE" + "MAKE-WEAK-POINTER" + "WEAK-POINTER" + "WEAK-POINTER-P" + "WEAK-POINTER-VALUE" + "MAKE-WEAK-VECTOR" + "WEAK-VECTOR-P" + + ;; Hash table extensions + "DEFINE-HASH-TABLE-TEST" + "HASH-TABLE-SYNCHRONIZED-P" + "HASH-TABLE-WEAKNESS" + "WITH-LOCKED-HASH-TABLE" + + ;; If the user knows we're doing IEEE, he might reasonably + ;; want to do this stuff. + "FLOAT-DENORMALIZED-P" + "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P" + "FLOAT-INFINITY-P" + "SHORT-FLOAT-NEGATIVE-INFINITY" + "SHORT-FLOAT-POSITIVE-INFINITY" + "SINGLE-FLOAT-NEGATIVE-INFINITY" + "SINGLE-FLOAT-POSITIVE-INFINITY" + "DOUBLE-FLOAT-NEGATIVE-INFINITY" + "DOUBLE-FLOAT-POSITIVE-INFINITY" + "LONG-FLOAT-NEGATIVE-INFINITY" + "LONG-FLOAT-POSITIVE-INFINITY" + + ;; saving Lisp images + "SAVE-LISP-AND-DIE" + + ;; provided for completeness to make it more convenient + ;; to use command-line --disable-debugger functionality + ;; in oddball situations (like building core files using + ;; scripts which run unattended, when the core files are + ;; intended for interactive use) + "DISABLE-DEBUGGER" + "ENABLE-DEBUGGER" + + ;; the mechanism by which {en,dis}able-debugger works is + ;; also exported for people writing alternative toplevels + ;; (Emacs, CLIM interfaces, etc) + "*INVOKE-DEBUGGER-HOOK*" + + ;; miscellaneous useful supported extensions + "QUIT" "EXIT" + "*ED-FUNCTIONS*" + "*MODULE-PROVIDER-FUNCTIONS*" + "MAP-DIRECTORY" + "WITH-TIMEOUT" "TIMEOUT" + "SEED-RANDOM-STATE" + "TYPEXPAND-1" "TYPEXPAND" "TYPEXPAND-ALL" + "DEFINED-TYPE-NAME-P" "VALID-TYPE-SPECIFIER-P" + "DELETE-DIRECTORY" + "SET-SBCL-SOURCE-LOCATION" + "*DISASSEMBLE-ANNOTATE*" + "PRINT-SYMBOL-WITH-PREFIX" + "*PRINT-VECTOR-LENGTH*" + "DECIMAL-WITH-GROUPED-DIGITS-WIDTH" + ;;"OBJECT-SIZE" + + ;; stepping interface + "STEP-CONDITION" "STEP-FORM-CONDITION" "STEP-FINISHED-CONDITION" + "STEP-VALUES-CONDITION" + "STEP-CONDITION-FORM" "STEP-CONDITION-RESULT" + "STEP-CONTINUE" "STEP-NEXT" "STEP-INTO" + "STEP-CONDITION-ARGS" "*STEPPER-HOOK*" "STEP-OUT" + + ;; RUN-PROGRAM is not only useful for users, but also + ;; useful to implement parts of SBCL itself, so we're + ;; going to have to implement it anyway, so we might + ;; as well support it. And then once we're committed + ;; to implementing RUN-PROGRAM, it's nice to have it + ;; return a PROCESS object with operations defined on + ;; that object. + "RUN-PROGRAM" + "PROCESS-ALIVE-P" "PROCESS-CLOSE" + "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE" + "PROCESS-INPUT" "PROCESS-KILL" "PROCESS-OUTPUT" "PROCESS-P" + "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS" + "PROCESS-STATUS-HOOK" "PROCESS-WAIT" + + ;; pathnames + "NATIVE-PATHNAME" + "PARSE-NATIVE-NAMESTRING" + "NATIVE-NAMESTRING" + + ;; external-format support + "OCTETS-TO-STRING" "STRING-TO-OCTETS" + + ;; Whether to use the interpreter or the compiler for EVAL + "*EVALUATOR-MODE*" + + ;; timer + "TIMER" "MAKE-TIMER" "TIMER-NAME" "TIMER-SCHEDULED-P" + "SCHEDULE-TIMER" "UNSCHEDULE-TIMER" "LIST-ALL-TIMERS" + + ;; SIMD pack + #+sb-simd-pack + ("SIMD-PACK" + "SIMD-PACK-P" + "%MAKE-SIMD-PACK-UB32" + "%MAKE-SIMD-PACK-UB64" + "%MAKE-SIMD-PACK-DOUBLE" + "%MAKE-SIMD-PACK-SINGLE" + "%SIMD-PACK-UB32S" + "%SIMD-PACK-UB64S" + "%SIMD-PACK-DOUBLES" + "%SIMD-PACK-SINGLES") + #+sb-simd-pack-256 + ("SIMD-PACK-256" + "SIMD-PACK-256-P" + "%MAKE-SIMD-PACK-256-UB32" + "%MAKE-SIMD-PACK-256-UB64" + "%MAKE-SIMD-PACK-256-DOUBLE" + "%MAKE-SIMD-PACK-256-SINGLE" + "%SIMD-PACK-256-UB32S" + "%SIMD-PACK-256-UB64S" + "%SIMD-PACK-256-DOUBLES" + "%SIMD-PACK-256-SINGLES") + + ;; versioning utility + "ASSERT-VERSION->=" + "UNKNOWN-KEYWORD-ARGUMENT" + "UNKNOWN-KEYWORD-ARGUMENT-NAME")) + + #s(sb-cold:package-data + :name "SB-FORMAT" + :doc "private: implementation of FORMAT and friends" + :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") + :export ("%COMPILER-WALK-FORMAT-STRING" "FORMAT-ERROR" "TOKENS")) + + #s(sb-cold:package-data + :name "SB-GRAY" + :doc + "public: an implementation of the stream-definition-by-user +Lisp extension proposal by David N. Gray" + :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") + :export ("FUNDAMENTAL-BINARY-STREAM" + "FUNDAMENTAL-BINARY-INPUT-STREAM" + "FUNDAMENTAL-BINARY-OUTPUT-STREAM" "FUNDAMENTAL-CHARACTER-STREAM" + "FUNDAMENTAL-CHARACTER-INPUT-STREAM" + "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" + "FUNDAMENTAL-INPUT-STREAM" "FUNDAMENTAL-OUTPUT-STREAM" + "FUNDAMENTAL-STREAM" + "STREAM-ADVANCE-TO-COLUMN" "STREAM-CLEAR-INPUT" + "STREAM-CLEAR-OUTPUT" "STREAM-FILE-POSITION" "STREAM-FINISH-OUTPUT" "STREAM-FORCE-OUTPUT" + "STREAM-FRESH-LINE" "STREAM-LINE-COLUMN" "STREAM-LINE-LENGTH" + "STREAM-LISTEN" "STREAM-PEEK-CHAR" "STREAM-READ-BYTE" + "STREAM-READ-CHAR" "STREAM-READ-CHAR-NO-HANG" "STREAM-READ-LINE" + "STREAM-READ-SEQUENCE" "STREAM-START-LINE-P" "STREAM-TERPRI" + "STREAM-UNREAD-CHAR" + "STREAM-WRITE-BYTE" "STREAM-WRITE-CHAR" "STREAM-WRITE-SEQUENCE" + "STREAM-WRITE-STRING")) + + #s(sb-cold:package-data + :name "SB-INT" + :doc + "private: miscellaneous unsupported extensions to the ANSI spec. Much of +the stuff in here originated in CMU CL's EXTENSIONS package and is retained, +possibly temporarily, because it might be used internally." + :use ("CL" "SB-ALIEN" "SB-GRAY" "SB-FASL" "SB-SYS") + :export (;; lambda list keyword extensions + "&MORE" + + ;; utilities for floating point zero handling + "FP-ZERO-P" + + ;; Advice to the compiler that it doesn't need to assert types. + "EXPLICIT-CHECK" + ;; Stack allocation without any questions asked + "TRULY-DYNAMIC-EXTENT" + + "WITH-SYSTEM-MUTEX" + "HASH-TABLE-LOCK" + + ;; generic set implementation backed by a list that upgrades + ;; to a hashtable if a certain size is exceeded. + "ADD-TO-XSET" + "ALLOC-XSET" + "MAP-XSET" + "XSET" + "XSET-COUNT" + "XSET-EMPTY-P" + "XSET-INTERSECTION" + "XSET-MEMBER-P" + "XSET-MEMBERS" + "XSET-SUBSET-P" + "XSET-UNION" + + ;; sparse set implementation backed by a lightweight hashtable + "COPY-SSET" + "DO-SSET-ELEMENTS" + "MAKE-SSET" + "SSET" "SSET-ELEMENT" + "SSET-ADJOIN" "SSET-DELETE" "SSET-EMPTY" "SSET-COUNT" + "SSET-MEMBER" + + ;; communication between the runtime and Lisp + "*CORE-STRING*" + + ;; INFO stuff doesn't belong in a user-visible package, we + ;; should be able to change it without apology. + "*INFO-ENVIRONMENT*" + "*RECOGNIZED-DECLARATIONS*" + "+INFOS-PER-WORD+" + "+FDEFN-INFO-NUM+" + "PACKED-INFO" + "+NIL-PACKED-INFOS+" + "ATOMIC-SET-INFO-VALUE" + "CALL-WITH-EACH-GLOBALDB-NAME" + "CLEAR-INFO" + "CLEAR-INFO-VALUES" + "DEFINE-INFO-TYPE" + "FIND-FDEFN" + "SYMBOL-FDEFN" + "GET-INFO-VALUE-INITIALIZING" + "GLOBALDB-SXHASHOID" + "GLOBAL-FTYPE" + "INFO" + "INFO-FIND-AUX-KEY/PACKED" + "INFO-GETHASH" + "INFO-MAPHASH" + "INFO-NUMBER" + "INFO-NUMBER-BITS" + "PACKED-INFO-FDEFN" + "MAKE-INFO-HASHTABLE" + "META-INFO" + "META-INFO-NUMBER" + "PACKED-INFO-FIELD" + "PACKED-INFO-INSERT" + "PCL-METHODFN-NAME-P" + "SET-INFO-VALUE" + "SHOW-INFO" + "UPDATE-SYMBOL-INFO" + "WITH-GLOBALDB-NAME" + "%BOUNDP" + + ;; Calling a list of hook functions, plus error handling. + "CALL-HOOKS" + ;; Constant form evaluation + "CONSTANT-FORM-VALUE" + + ;; stepping control + "*STEPPING*" + + ;; packages grabbed once and for all + "*KEYWORD-PACKAGE*" "*CL-PACKAGE*" + + ;; hash mixing operations + "MIX" "MIXF" "WORD-MIX" + + ;; Macroexpansion that doesn't touch special forms + "%MACROEXPAND" + "%MACROEXPAND-1" + + "*SETF-FDEFINITION-HOOK*" + + ;; error-reporting facilities + "ARGUMENTS-OUT-OF-DOMAIN-ERROR" + "CLOSED-STREAM-ERROR" "CLOSED-SAVED-STREAM-ERROR" + "COMPILED-PROGRAM-ERROR" + "COMPILER-MACRO-KEYWORD-PROBLEM" + "ENCAPSULATED-CONDITION" + "INVALID-ARRAY-ERROR" + "INVALID-ARRAY-INDEX-ERROR" + "INVALID-ARRAY-P" + "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR" + "SIMPLE-PARSE-ERROR" + "SIMPLE-PROGRAM-ERROR" "%PROGRAM-ERROR" + "SIMPLE-READER-ERROR" + "SIMPLE-READER-PACKAGE-ERROR" + "SIMPLE-REFERENCE-ERROR" + "SIMPLE-REFERENCE-WARNING" + "SIMPLE-STREAM-ERROR" + "SIMPLE-STORAGE-CONDITION" + "SIMPLE-STYLE-WARNING" + "STREAM-ERROR-POSITION-INFO" + "TRY-RESTART" + + "BROKEN-PIPE" + + ;; error-signalling facilities + "STANDARD-READTABLE-MODIFIED-ERROR" + "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" + "ARRAY-BOUNDING-INDICES-BAD-ERROR" + "CIRCULAR-LIST-ERROR" + "SEQUENCE-BOUNDING-INDICES-BAD-ERROR" + "SPECIAL-FORM-FUNCTION" + "STYLE-WARN" "SIMPLE-COMPILER-NOTE" + "TWO-ARG-CHAR-EQUAL" "TWO-ARG-CHAR-NOT-EQUAL" + "TWO-ARG-CHAR-LESSP" "TWO-ARG-CHAR-NOT-LESSP" + "TWO-ARG-CHAR-GREATERP" "TWO-ARG-CHAR-NOT-GREATERP" + "CHAR-CASE-INFO" + ;; FIXME: potential SB-EXT exports + "CHARACTER-CODING-ERROR" + "CHARACTER-DECODING-ERROR" "CHARACTER-DECODING-ERROR-OCTETS" + "CHARACTER-ENCODING-ERROR" "CHARACTER-ENCODING-ERROR-CODE" + "STREAM-DECODING-ERROR" "STREAM-ENCODING-ERROR" + "C-STRING-ENCODING-ERROR" + "C-STRING-DECODING-ERROR" + "ATTEMPT-RESYNC" "FORCE-END-OF-FILE" + + ;; bootstrapping magic, to make things happen both in + ;; the cross-compilation host compiler's environment and + ;; in the cross-compiler's environment + "DEF!STRUCT" "DEF!TYPE" + "*!REMOVABLE-SYMBOLS*" + + ;; bootstrapping macro whose effect is to delay until warm load. + "!SET-LOAD-FORM-METHOD" + + ;; stuff for hinting to the compiler + "NAMED-DS-BIND" + "NAMED-LAMBDA" + + ;; other variations on DEFFOO stuff useful for bootstrapping + ;; and cross-compiling + "DEFCONSTANT-EQX" + "DEFINE-UNSUPPORTED-FUN" + + ;; messing with PATHNAMEs + "MAKE-TRIVIAL-DEFAULT-PATHNAME" + "PHYSICALIZE-PATHNAME" + "SANE-DEFAULT-PATHNAME-DEFAULTS" + "SBCL-HOMEDIR-PATHNAME" + "SIMPLIFY-NAMESTRING" + "DEBUG-SOURCE-NAMESTRING" + "DEBUG-SOURCE-CREATED" + + "*N-BYTES-FREED-OR-PURIFIED*" + + ;; Deprecating stuff + "DEFINE-DEPRECATED-FUNCTION" + "DEFINE-DEPRECATED-VARIABLE" + "DEPRECATION-STATE" + "DEPRECATION-INFO" "MAKE-DEPRECATION-INFO" + "DEPRECATION-INFO-STATE" + "DEPRECATION-INFO-SOFTWARE" + "DEPRECATION-INFO-VERSION" + "DEPRECATION-INFO-REPLACEMENTS" + "PRINT-DEPRECATION-MESSAGE" + "CHECK-DEPRECATED-THING" "CHECK-DEPRECATED-TYPE" + "DEPRECATED-THING-P" + "DEPRECATION-WARN" + "LOADER-DEPRECATION-WARN" + + ;; miscellaneous non-standard but handy user-level functions.. + "ASSQ" "DELQ" "DELQ1" "MEMQ" "POSQ" "NEQ" + "ADJUST-LIST" + "ALIGN-UP" + "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE" + "SANE-PACKAGE" + "COALESCE-TREE-P" + "COMPOUND-OBJECT-P" + "SWAPPED-ARGS-FUN" + "AND/TYPE" "NOT/TYPE" + "ANY/TYPE" "EVERY/TYPE" + "EQUAL-BUT-NO-CAR-RECURSION" + "TYPE-BOUND-NUMBER" "COERCE-NUMERIC-BOUND" + "CONSTANTLY-T" "CONSTANTLY-NIL" "CONSTANTLY-0" + "PSXHASH" + "%BREAK" + "BIT-VECTOR-=" + "PATHNAME=" + "%HASH-TABLE-ALIST" + "HASH-TABLE-EQUALP" + "READ-EVALUATED-FORM" "READ-EVALUATED-FORM-OF-TYPE" + "PICK-BEST-SXHASH-BITS" + + "MAKE-UNPRINTABLE-OBJECT" + "POSSIBLY-BASE-STRINGIZE" + "POWER-OF-TWO-CEILING" + "PRINT-NOT-READABLE-ERROR" + "HASH-TABLE-REPLACE" + "RECONS" + "SET-CLOSURE-NAME" + + ;; ..and macros.. + "COLLECT" + "COPY-LIST-MACRO" + "DO-ANONYMOUS" "DOVECTOR" "DOHASH" "DOPLIST" + "ENSURE-GETHASH" + "GET-SIMILAR" + "NAMED-LET" + "ONCE-ONLY" + "DEFENUM" + "DEFPRINTER" + "*PRINT-IR-NODES-PRETTY*" + "AVER" + "DX-FLET" "DX-LET" + "AWHEN" "ACOND" "IT" + "BINDING*" "EXTRACT-VAR-DECLS" + "!DEF-BOOLEAN-ATTRIBUTE" + "FUNARG-BIND/CALL-FORMS" + "QUASIQUOTE" + "COMMA-P" + "COMMA-EXPR" + "COMMA-KIND" + "UNQUOTE" + "PACKAGE-HASHTABLE" + "PACKAGE-ITER-STEP" + "WITH-REBOUND-IO-SYNTAX" + "WITH-SANE-IO-SYNTAX" + "WITH-PROGRESSIVE-TIMEOUT" + + ;; ..and CONDITIONs.. + "BUG" + "UNSUPPORTED-OPERATOR" + + "BOOTSTRAP-PACKAGE-NAME" + "BOOTSTRAP-PACKAGE-NOT-FOUND" + "DEBOOTSTRAP-PACKAGE" + "SYSTEM-PACKAGE-P" + + "REFERENCE-CONDITION" "REFERENCE-CONDITION-REFERENCES" + "*PRINT-CONDITION-REFERENCES*" + + "DUPLICATE-DEFINITION" "DUPLICATE-DEFINITION-NAME" + "SAME-FILE-REDEFINITION-WARNING" + "PACKAGE-AT-VARIANCE" + "PACKAGE-AT-VARIANCE-ERROR" + "ARRAY-INITIAL-ELEMENT-MISMATCH" + "INITIAL-ELEMENT-MISMATCH-STYLE-WARNING" + "TYPE-WARNING" "TYPE-STYLE-WARNING" + "SLOT-INITFORM-TYPE-STYLE-WARNING" + "LOCAL-ARGUMENT-MISMATCH" + "FORMAT-ARGS-MISMATCH" "FORMAT-TOO-FEW-ARGS-WARNING" + "FORMAT-TOO-MANY-ARGS-WARNING" "EXTENSION-FAILURE" + "STRUCTURE-INITARG-NOT-KEYWORD" "CONSTANT-MODIFIED" + + ;; ..and DEFTYPEs.. + "HASH-CODE" + "INDEX" "LOAD/STORE-INDEX" + "SIGNED-BYTE-WITH-A-BITE-OUT" + "UNSIGNED-BYTE-WITH-A-BITE-OUT" + "SFUNCTION" "UNSIGNED-BYTE*" + "CONSTANT-DISPLACEMENT" + "EXTENDED-FUNCTION-DESIGNATOR" + "EXTENDED-FUNCTION-DESIGNATOR-P" + ;; ..and type predicates + "DOUBLE-FLOAT-P" + "LOGICAL-PATHNAME-P" + "LONG-FLOAT-P" + "SHORT-FLOAT-P" + "SINGLE-FLOAT-P" + "FIXNUMP" + "BIGNUMP" + "RATIOP" + "UNBOUND-MARKER-P" + + ;; encapsulation + "ENCAPSULATE" "ENCAPSULATED-P" + "UNENCAPSULATE" + "ENCAPSULATE-FUNOBJ" + + ;; various CHAR-CODEs + "BACKSPACE-CHAR-CODE" "BELL-CHAR-CODE" "ESCAPE-CHAR-CODE" + "FORM-FEED-CHAR-CODE" "LINE-FEED-CHAR-CODE" + "RETURN-CHAR-CODE" "RUBOUT-CHAR-CODE" "TAB-CHAR-CODE" + + ;; symbol-hacking idioms + "GENSYMIFY" "GENSYMIFY*" "KEYWORDICATE" "SYMBOLICATE" + "INTERNED-SYMBOL-P" "PACKAGE-SYMBOLICATE" + "LOGICALLY-READONLYIZE" + + ;; certainly doesn't belong in public extensions + ;; FIXME: maybe belongs in %KERNEL with other typesystem stuff? + "CONSTANT-ARG" + + ;; various internal defaults + "*LOAD-SOURCE-DEFAULT-TYPE*" "BASE-CHAR-CODE-LIMIT" + + ;; hash caches + "DEFUN-CACHED" + "DROP-ALL-HASH-CACHES" + + ;; time + "FORMAT-DECODED-TIME" + "FORMAT-UNIVERSAL-TIME" + + ;; used for FORMAT tilde paren + "MAKE-CASE-FROB-STREAM" + + ;; helpers for C library calls + "STRERROR" "SIMPLE-PERROR" + + ;; debuggers' little helpers + #+sb-show("*/SHOW*" + "HEXSTR") + "/SHOW" "/NOSHOW" + "/SHOW0" "/NOSHOW0" + + ;; cross-compilation bootstrap hacks which turn into + ;; placeholders in a target system + "UNCROSS" + "!UNCROSS-FORMAT-CONTROL" + + ;; might as well be shared among the various files which + ;; need it: + "*EOF-OBJECT*" + + ;; allocation to static space + "MAKE-STATIC-VECTOR" + + ;; alien interface utilities + "C-STRINGS->STRING-LIST" + + ;; misc. utilities used internally + "ADDRESS-BASED-COUNTER-VAL" + "DEFINE-FUNCTION-NAME-SYNTAX" "VALID-FUNCTION-NAME-P" ; should be SB-EXT? + "LEGAL-VARIABLE-NAME-P" + "LEGAL-FUN-NAME-P" "LEGAL-FUN-NAME-OR-TYPE-ERROR" + "FUN-NAME-BLOCK-NAME" + "FUN-NAME-INLINE-EXPANSION" + "LISTEN-SKIP-WHITESPACE" + "PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT" + "PARSE-BODY" "PARSE-LAMBDA-LIST" "MAKE-LAMBDA-LIST" + "CHECK-DESIGNATOR" + "CHECK-LAMBDA-LIST-NAMES" + "LAMBDA-LIST-KEYWORD-MASK" + "PARSE-KEY-ARG-SPEC" "PARSE-OPTIONAL-ARG-SPEC" + "LL-KWDS-RESTP" "LL-KWDS-KEYP" "LL-KWDS-ALLOWP" + "MAKE-MACRO-LAMBDA" + "PROPER-LIST-OF-LENGTH-P" "PROPER-LIST-P" + "LIST-OF-LENGTH-AT-LEAST-P" "SEQUENCE-OF-LENGTH-AT-LEAST-P" + "SINGLETON-P" "ENSURE-LIST" + "MISSING-ARG" + "FEATUREP" + "FLUSH-STANDARD-OUTPUT-STREAMS" + "WITH-UNIQUE-NAMES" "MAKE-GENSYM-LIST" + "ABOUT-TO-MODIFY-SYMBOL-VALUE" + "SELF-EVALUATING-P" + "PRINT-PRETTY-ON-STREAM-P" + "ARRAY-READABLY-PRINTABLE-P" + "LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P" + "POSITIVE-PRIMEP" + "EVAL-IN-LEXENV" + "SIMPLE-EVAL-IN-LEXENV" + "FORCE" "DELAY" "PROMISE-READY-P" + "FIND-RESTART-OR-CONTROL-ERROR" + "LOAD-AS-SOURCE" + "DESCRIPTOR-SAP" + "DO-PACKED-VARINTS" + + "CLOSURE-EXTRA-VALUES" + "PACK-CLOSURE-EXTRA-VALUES" + "SET-CLOSURE-EXTRA-VALUES" + "+CLOSURE-NAME-INDEX+" + + ;; These could be moved back into SB-EXT if someone has + ;; compelling reasons, but hopefully we can get by + ;; without supporting them, at least not as publicly + ;; accessible things with fixed interfaces. + "GET-FLOATING-POINT-MODES" + "SET-FLOATING-POINT-MODES" + "WITH-FLOAT-TRAPS-MASKED" + + ;; a sort of quasi-unbound tag for use in hash tables + "+EMPTY-HT-SLOT+" + + ;; low-level i/o stuff + "DONE-WITH-FAST-READ-CHAR" + "FAST-READ-BYTE" + "FAST-READ-BYTE-REFILL" + "FAST-READ-CHAR" + "FAST-READ-CHAR-REFILL" + "FAST-READ-S-INTEGER" + "FAST-READ-U-INTEGER" + "FAST-READ-VAR-U-INTEGER" + "FILE-NAME" + "FORM-TRACKING-STREAM" + "FORM-TRACKING-STREAM-OBSERVER" + "FORM-TRACKING-STREAM-P" + "FORM-TRACKING-STREAM-FORM-START-BYTE-POS" + "FORM-TRACKING-STREAM-FORM-START-CHAR-POS" + "LINE/COL-FROM-CHARPOS" + "%INTERN" + "WITH-FAST-READ-BYTE" + "PREPARE-FOR-FAST-READ-CHAR" + "OUT-STREAM-FROM-DESIGNATOR" + "STRINGIFY-OBJECT" + "%WRITE" + + ;; hackery to help set up for cold init + "!BEGIN-COLLECTING-COLD-INIT-FORMS" + "!COLD-INIT-FORMS" + "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS" + + ;; catch tags + "TOPLEVEL-CATCHER" + + ;; hooks for contrib/ stuff we're insufficiently sure + ;; about to add to SB-EXT + "*REPL-PROMPT-FUN*" + "*REPL-READ-FORM-FUN*" + + ;; Character database + "**CHARACTER-PRIMARY-COMPOSITIONS**" + "**CHARACTER-COLLATIONS**" + + ;; Character database access + "MISC-INDEX" + "CLEAR-FLAG" + "PACK-3-CODEPOINTS" + + ;; Huffman trees + "HUFFMAN-ENCODE" + "HUFFMAN-DECODE" + "BINARY-SEARCH" + "DOUBLE-VECTOR-BINARY-SEARCH")) + + ;; FIXME: This package is awfully huge. It'd probably be good to + ;; split it. There's at least one natural way to split it: the + ;; implementation of the Lisp type system (e.g. TYPE-INTERSECTION and + ;; SPECIFIER-TYPE) could move to a separate package SB-TYPE. (There's + ;; lots of stuff which currently uses the SB-KERNEL package which + ;; doesn't actually use the type system stuff.) And maybe other + ;; possible splits too: + ;; * Pull GC stuff (*GC-INHIBIT*, *GC-PENDING*, etc.) + ;; out into SB-GC. + ;; * Pull special case implementations of sequence functions (e.g. + ;; %MAP-TO-LIST-ARITY-1 and %FIND-POSITION-IF-NOT) and + ;; other sequence function implementation grot into SB-SEQ. + ;; * Pull all the math stuff (%ACOS, %COSH, WORD-LOGICAL-AND...) + ;; into SB-MATH. + ;; * Pull all the array stuff (%ARRAY-DATA, + ;; WITH-ARRAY-DATA, ALLOCATE-VECTOR, HAIRY-DATA-VECTOR-REF...) + ;; into SB-ARRAY. + ;; * Pull all the streams stuff out into SB-STREAM. + ;; * Pull all the OBJECT-NOT-FOO symbols out. Maybe we could even + ;; figure out a way to stop exporting them? Failing that, + ;; they could be in SB-INTERR. + ;; Or better still, since error names are basically meaningless except + ;; for the ~18 errors that are _not_ object-not-, stop naming them. + ;; C just needs a map from number -> string-to-show. + #s(sb-cold:package-data + :name "SB-KERNEL" + :doc + "private: Theoretically this 'hides state and types used for package +integration' (said CMU CL architecture.tex) and that probably was and +is a good idea, but see SB-SYS re. blurring of boundaries." + :use ("CL" "SB-ALIEN" "SB-ALIEN-INTERNALS" "SB-BIGNUM" + "SB-EXT" "SB-FASL" "SB-INT" "SB-SYS" "SB-GRAY") + :reexport (#+sb-simd-pack("SIMD-PACK" + "SIMD-PACK-P" + "%MAKE-SIMD-PACK-UB32" + "%MAKE-SIMD-PACK-UB64" + "%MAKE-SIMD-PACK-DOUBLE" + "%MAKE-SIMD-PACK-SINGLE" + "%SIMD-PACK-UB32S" + "%SIMD-PACK-UB64S" + "%SIMD-PACK-DOUBLES" + "%SIMD-PACK-SINGLES")) + :export ("%%DATA-VECTOR-REFFERS%%" + "%%DATA-VECTOR-SETTERS%%" + "%ACOS" + "%ACOSH" + "%ADJOIN" + "%ADJOIN-EQ" + "%ADJOIN-KEY" + "%ADJOIN-KEY-EQ" + "%ADJOIN-KEY-TEST" + "%ADJOIN-KEY-TEST-NOT" + "%ADJOIN-TEST" + "%ADJOIN-TEST-NOT" + "%ARRAY-AVAILABLE-ELEMENTS" + "%ARRAY-DATA" + "%ARRAY-DATA-VECTOR" ; DO NOT USE !!! + "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" + "%ARRAY-DISPLACED-FROM" + "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" + "%ARRAY-RANK" "%ARRAY-RANK=" + "SIMPLE-ARRAY-HEADER-OF-RANK-P" + "%ARRAY-ATOMIC-INCF/WORD" + "%ASH/RIGHT" + "%ASSOC" + "%ASSOC-EQ" + "%ASSOC-IF" + "%ASSOC-IF-KEY" + "%ASSOC-IF-NOT" + "%ASSOC-IF-NOT-KEY" + "%ASSOC-KEY" + "%ASSOC-KEY-EQ" + "%ASSOC-KEY-TEST" + "%ASSOC-KEY-TEST-NOT" + "%ASSOC-TEST" + "%ASSOC-TEST-NOT" + "%ASIN" "%ASINH" + "%ATAN" "%ATAN2" "%ATANH" + "%ATOMIC-DEC-CAR" "%ATOMIC-INC-CAR" + "%ATOMIC-DEC-CDR" "%ATOMIC-INC-CDR" + "%ATOMIC-DEC-SYMBOL-GLOBAL-VALUE" + "%ATOMIC-INC-SYMBOL-GLOBAL-VALUE" + "%CALLER-FRAME" + "%CALLER-PC" + "%CHECK-BOUND" "CHECK-BOUND" + "%CHECK-GENERIC-SEQUENCE-BOUNDS" + "%CHECK-VECTOR-SEQUENCE-BOUNDS" + "%CAS-SYMBOL-GLOBAL-VALUE" + "%COPY-INSTANCE" "%COPY-INSTANCE-SLOTS" + "%COMPARE-AND-SWAP-CAR" + "%COMPARE-AND-SWAP-CDR" + "%COMPARE-AND-SWAP-SVREF" + "%COMPARE-AND-SWAP-SYMBOL-VALUE" + "%CONCATENATE-TO-BASE-STRING" + "%CONCATENATE-TO-STRING" + "%CONCATENATE-TO-SIMPLE-VECTOR" + "%CONCATENATE-TO-LIST" "%CONCATENATE-TO-VECTOR" + "CONTAINS-UNKNOWN-TYPE-P" + "%COS" "%COS-QUICK" + "%COSH" "%DATA-VECTOR-AND-INDEX" "%DEPOSIT-FIELD" + "%DOUBLE-FLOAT" "%DPB" "%EQL" "%EQL/INTEGER" + "%EXIT" + "%EXP" "%EXPM1" + "%FIND-POSITION" + "%FIND-POSITION-VECTOR-MACRO" "%FIND-POSITION-IF" + "%FIND-POSITION-IF-VECTOR-MACRO" "%FIND-POSITION-IF-NOT" + "%FIND-POSITION-IF-NOT-VECTOR-MACRO" + "FIXNUM-MOD-P" + "%HYPOT" + "%INSTANCE-CAS" + "%LDB" "%LOG" "%LOGB" "%LOG10" + "%LAST0" + "%LAST1" + "%LASTN/FIXNUM" + "%LASTN/BIGNUM" + "%LOG1P" + #+long-float "%LONG-FLOAT" + "%MAKE-ARRAY" + "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" + "%MAKE-FUNCALLABLE-STRUCTURE-INSTANCE-ALLOCATOR" + "%MAKE-INSTANCE" + "%MAKE-LISP-OBJ" + "%MAKE-LIST" + "%MAKE-RATIO" + #+sb-simd-pack "%MAKE-SIMD-PACK" + #+sb-simd-pack-256 "%MAKE-SIMD-PACK-256" + "%MAKE-STRUCTURE-INSTANCE" + "%MAKE-STRUCTURE-INSTANCE-ALLOCATOR" + "%MAP" "%MAP-FOR-EFFECT-ARITY-1" + "%MAP-TO-LIST-ARITY-1" "%MAP-TO-SIMPLE-VECTOR-ARITY-1" + "%MASK-FIELD" + "%MEMBER" + "%MEMBER-EQ" + "%MEMBER-IF" + "%MEMBER-IF-KEY" + "%MEMBER-IF-NOT" + "%MEMBER-IF-NOT-KEY" + "%MEMBER-KEY" + "%MEMBER-KEY-EQ" + "%MEMBER-KEY-TEST" + "%MEMBER-KEY-TEST-NOT" + "%MEMBER-TEST" + "%MEMBER-TEST-NOT" + "%MULTIPLY-HIGH" "%SIGNED-MULTIPLY-HIGH" + "%NEGATE" "%POW" + "%OTHER-POINTER-WIDETAG" + "%PCL-INSTANCE-P" + "%PUTHASH" + "%RASSOC" + "%RASSOC-EQ" + "%RASSOC-IF" + "%RASSOC-IF-KEY" + "%RASSOC-IF-NOT" + "%RASSOC-IF-NOT-KEY" + "%RASSOC-KEY" + "%RASSOC-KEY-EQ" + "%RASSOC-KEY-TEST" + "%RASSOC-KEY-TEST-NOT" + "%RASSOC-TEST" + "%RASSOC-TEST-NOT" + "%VECTOR-RAW-BITS" + "%SCALB" "%SCALBN" + "%RAW-INSTANCE-ATOMIC-INCF/WORD" + "%RAW-INSTANCE-CAS/WORD" "%RAW-INSTANCE-XCHG/WORD" + "%RAW-INSTANCE-REF/WORD" "%RAW-INSTANCE-SET/WORD" + "%RAW-INSTANCE-CAS/SIGNED-WORD" + "%RAW-INSTANCE-REF/SIGNED-WORD" "%RAW-INSTANCE-SET/SIGNED-WORD" + "%RAW-INSTANCE-REF/SINGLE" "%RAW-INSTANCE-SET/SINGLE" + "%RAW-INSTANCE-REF/DOUBLE" "%RAW-INSTANCE-SET/DOUBLE" + "%RAW-INSTANCE-REF/COMPLEX-SINGLE" + "%RAW-INSTANCE-SET/COMPLEX-SINGLE" + "%RAW-INSTANCE-REF/COMPLEX-DOUBLE" + "%RAW-INSTANCE-SET/COMPLEX-DOUBLE" + "ROUND-DOUBLE" "ROUND-SINGLE" + "%SET-ARRAY-DIMENSION" "%SET-FUNCALLABLE-INSTANCE-INFO" + "%SET-VECTOR-RAW-BITS" + "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64" + "%SET-SAP-REF-WORD" "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE" + "%SET-SAP-REF-LISPOBJ" "%SET-SAP-REF-LONG" "%SET-SAP-REF-SAP" + "%SET-SAP-REF-SINGLE" "%SET-SIGNED-SAP-REF-16" + "%SET-SIGNED-SAP-REF-32" "%SET-SIGNED-SAP-REF-64" + "%SET-SIGNED-SAP-REF-WORD" + "%SET-SIGNED-SAP-REF-8" "%SET-STACK-REF" + "%SET-SYMBOL-HASH" + "%SIN" "%SIN-QUICK" "%SINGLE-FLOAT" + "%SINH" "%SQRT" + "%SXHASH-BIT-VECTOR" "%SXHASH-SIMPLE-BIT-VECTOR" + "%SXHASH-STRING" "%SXHASH-SIMPLE-STRING" + #+sb-simd-pack + ("%SIMD-PACK-TAG" + "%SIMD-PACK-LOW" + "%SIMD-PACK-HIGH") + #+sb-simd-pack-256 + ("%SIMD-PACK-256-TAG" + "%SIMD-PACK-256-0" "%SIMD-PACK-256-1" + "%SIMD-PACK-256-2" "%SIMD-PACK-256-3") + "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK" "%TANH" + "THE*" + "%UNARY-ROUND" + "%UNARY-TRUNCATE" + "%UNARY-TRUNCATE/SINGLE-FLOAT" + "%UNARY-TRUNCATE/DOUBLE-FLOAT" + "%UNARY-FTRUNCATE" + "%WITH-ARRAY-DATA" + "%WITH-ARRAY-DATA/FP" + "%WITH-ARRAY-DATA-MACRO" + "*APPROXIMATE-NUMERIC-UNIONS*" + "*CURRENT-INTERNAL-ERROR-CONTEXT*" + "*CURRENT-LEVEL-IN-PRINT*" + "*EMPTY-TYPE*" + "*EVAL-CALLS*" + "*GC-INHIBIT*" "*GC-PENDING*" + "*GC-PIN-CODE-PAGES*" + #+sb-thread "*STOP-FOR-GC-PENDING*" + "*IN-WITHOUT-GCING*" + "*UNIVERSAL-TYPE*" + "*UNIVERSAL-FUN-TYPE*" "*UNPARSE-FUN-TYPE-SIMPLIFY*" + "*WILD-TYPE*" "WORD-LOGICAL-AND" "WORD-LOGICAL-ANDC1" + "WORD-LOGICAL-ANDC2" "WORD-LOGICAL-EQV" + "WORD-LOGICAL-NAND" "WORD-LOGICAL-NOR" "WORD-LOGICAL-NOT" + "WORD-LOGICAL-OR" "WORD-LOGICAL-ORC1" "WORD-LOGICAL-ORC2" + "WORD-LOGICAL-XOR" + "ALLOW-NON-RETURNING-TAIL-CALL" + "ALIEN-TYPE-TYPE" "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P" + "ALLOCATE-VECTOR" "ALLOCATE-STATIC-VECTOR" + "ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" + "BUILD-RATIO" + "PROGRAM-ASSERT-SYMBOL-HOME-PACKAGE-UNLOCKED" + "DISABLED-PACKAGE-LOCKS" + "WITH-SINGLE-PACKAGE-LOCKED-ERROR" + "ARGS-TYPE" "ARGS-TYPE-ALLOWP" "ARGS-TYPE-KEYP" + "ARGS-TYPE-KEYWORDS" "ARGS-TYPE-OPTIONAL" "ARGS-TYPE-P" + "ARGS-TYPE-REQUIRED" "ARGS-TYPE-REST" + "ARRAY-HEADER-P" "SIMPLE-ARRAY-HEADER-P" + "ARRAY-TYPE" "ARRAY-TYPE-COMPLEXP" + "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE" + "ARRAY-TYPE-P" "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" + "ARRAY-UNDERLYING-WIDETAG" + "ASSERT-ERROR" + #+sb-unicode "BASE-CHAR-P" + "BASE-STRING-P" + "BIND" "BINDING-STACK-POINTER-SAP" "BIT-INDEX" + "BOGUS-ARG-TO-VALUES-LIST-ERROR" "BOOLE-CODE" + "BOUNDING-INDICES-BAD-ERROR" "BYTE-SPECIFIER" "%BYTE-BLT" + "FUNCTION-DESIGNATOR" + "CASE-BODY-ERROR" + "CHARACTER-SET" "CHARACTER-SET-TYPE" + "CHARACTER-SET-TYPE-PAIRS" + #+sb-unicode "CHARACTER-STRING-P" + "CHARPOS" + "CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR" "CLOSED-FLAME" + "CLASS-CLASSOID" + "CODE-COMPONENT" "CODE-COMPONENT-P" + "CODE-HEADER-REF" "CODE-HEADER-SET" "CODE-HEADER-WORDS" + "CODE-JUMP-TABLE-WORDS" + "CODE-INSTRUCTIONS" "CODE-N-UNBOXED-DATA-BYTES" + "CODE-OBJECT-SIZE" "CODE-TRAILER-REF" + "COERCE-SYMBOL-TO-FUN" + "COERCE-TO-FUN" "COERCE-TO-LEXENV" "COERCE-TO-LIST" + "COERCE-TO-VALUES" "COERCE-TO-VECTOR" + "COMPLEX-DOUBLE-FLOAT" "COMPLEX-DOUBLE-FLOAT-P" + "COMPLEX-FLOAT-P" + #+long-float ("COMPLEX-LONG-FLOAT" "COMPLEX-LONG-FLOAT-P") + "COMPLEX-RATIONAL-P" + "COMPLEX-SINGLE-FLOAT" "COMPLEX-SINGLE-FLOAT-P" + "COMPLEX-VECTOR-P" "COMPOUND-TYPE" "COMPOUND-TYPE-P" + "COMPOUND-TYPE-TYPES" + "CONDITION-DESIGNATOR-HEAD" + "CONS-TYPE" "CONS-TYPE-CAR-TYPE" + "CONS-TYPE-CDR-TYPE" "CONS-TYPE-P" "CONSED-SEQUENCE" + "CONSTANT" "CONSTANT-TYPE" "CONSTANT-TYPE-P" + "CONSTANT-TYPE-TYPE" "CONTAINING-INTEGER-TYPE" + "CONTROL-STACK-POINTER-SAP" + "CSUBTYPEP" "CTYPE" "TYPE-HASH-VALUE" "CTYPE-OF" + "CTYPE-P" "CTYPEP" + "CTYPE-ARRAY-DIMENSIONS" "CTYPE-ARRAY-SPECIALIZED-ELEMENT-TYPES" + "CURRENT-FP" "CURRENT-SP" "CURRENT-DYNAMIC-SPACE-START" + "DATA-NIL-VECTOR-REF" + "DATA-VECTOR-REF" "DATA-VECTOR-REF-WITH-OFFSET" + "DATA-VECTOR-SET" "DATA-VECTOR-SET-WITH-OFFSET" + "DECLARATION-TYPE-CONFLICT-ERROR" + "DECODE-DOUBLE-FLOAT" + #+long-float "DECODE-LONG-FLOAT" + "DECODE-SINGLE-FLOAT" + "DEFINE-STRUCTURE-SLOT-ADDRESSOR" + "DEFINED-FTYPE-MATCHES-DECLARED-FTYPE-P" + "!DEFSTRUCT-WITH-ALTERNATE-METACLASS" "DESCEND-INTO" + "DIVISION-BY-ZERO-ERROR" + "DO-REST-ARG" + "DO-INSTANCE-TAGGED-SLOT" + "DOUBLE-FLOAT-EXPONENT" + "DOUBLE-FLOAT-BITS" + "DOUBLE-FLOAT-HIGH-BITS" "DOUBLE-FLOAT-INT-EXPONENT" + "DOUBLE-FLOAT-LOW-BITS" "DOUBLE-FLOAT-SIGNIFICAND" + "DSD-ACCESSOR-NAME" "DSD-ALWAYS-BOUNDP" "DSD-DEFAULT" "DSD-INDEX" + "DSD-NAME" "DSD-RAW-TYPE" "DSD-READ-ONLY" "DSD-TYPE" + "DYNBIND" + "FLOAT-WAIT" "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE" + "EFFECTIVE-FIND-POSITION-TEST" + "EFFECTIVE-FIND-POSITION-KEY" + "ENSURE-SYMBOL-HASH" + "ENSURE-SYMBOL-TLS-INDEX" + "ERROR-NUMBER-OR-LOSE" + "EXTERNAL-FORMAT-DESIGNATOR" + "FAST-&REST-NTH" + "FILENAME" + "FILL-ARRAY" + "FILL-DATA-VECTOR" + "FIND-DEFSTRUCT-DESCRIPTION" + "FIND-OR-CREATE-FDEFN" + "FLOAT-EXPONENT" + "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME" + "FLOAT-FORMAT-MAX" "FLOAT-INT-EXPONENT" + "FLOAT-INFINITY-OR-NAN-P" + "FLOAT-SIGN-BIT" + "FLOATING-POINT-EXCEPTION" "FORM" "FORMAT-CONTROL" + "*FREE-INTERRUPT-CONTEXT-INDEX*" "FUNCALLABLE-INSTANCE-P" + "FSC-INSTANCE-HASH" + "%FUN-CODE-OFFSET" "FUN-CODE-HEADER" + "FUN-DESIGNATOR-TYPE" "FUN-DESIGNATOR-TYPE-P" + "FUN-TYPE" "FUN-TYPE-ALLOWP" + "FUN-TYPE-KEYP" "FUN-TYPE-KEYWORDS" "FUN-TYPE-NARGS" + "FUN-TYPE-OPTIONAL" "FUN-TYPE-P" "FUN-TYPE-REQUIRED" + "FUN-TYPE-REST" "FUN-TYPE-RETURNS" "FUN-TYPE-WILD-ARGS" + "GENERALIZED-BOOLEAN" + "GENERIC-ABSTRACT-TYPE-FUNCTION" + "GET-CLOSURE-LENGTH" "GET-HEADER-DATA" + "FUNCTION-HEADER-WORD" + "INSTANCE-HEADER-WORD" + "GET-LISP-OBJ-ADDRESS" "GENERATION-OF" + "LOWTAG-OF" "WIDETAG-OF" "WIDETAG=" + "HAIRY-DATA-VECTOR-REF" + "HAIRY-DATA-VECTOR-REF/CHECK-BOUNDS" "HAIRY-DATA-VECTOR-SET" + "HAIRY-DATA-VECTOR-SET/CHECK-BOUNDS" + "HAIRY-TYPE" "HAIRY-TYPE-P" "HAIRY-TYPE-SPECIFIER" + "HANDLE-CIRCULARITY" "HOST" "ILL-BIN" + "ILL-BOUT" "ILL-IN" "ILL-OUT" "INDEX-OR-MINUS-1" + "INDEX-TOO-LARGE-ERROR" "*!INITIAL-ASSEMBLER-ROUTINES*" + "*!INITIAL-SYMBOLS*" + "INTEGER-DECODE-DOUBLE-FLOAT" + #+long-float "INTEGER-DECODE-LONG-FLOAT" + "INTEGER-DECODE-SINGLE-FLOAT" "INTERNAL-ERROR" + #+win32 "HANDLE-WIN32-EXCEPTION" + "INTERNAL-TIME" "INTERNAL-SECONDS" + "INTERNAL-SECONDS-LIMIT" "SAFE-INTERNAL-SECONDS-LIMIT" + "INTERPRETED-FUNCTION" + "INTERSECTION-TYPE" "INTERSECTION-TYPE-P" + "INTERSECTION-TYPE-TYPES" "INVALID-ARG-COUNT-ERROR" + "LOCAL-INVALID-ARG-COUNT-ERROR" + "INVALID-UNWIND-ERROR" + "IRRATIONAL" "KEY-INFO" + "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" + "BITMAP-NWORDS" + "LAYOUT-DEPTHOID" + "LAYOUT-ID" + "LAYOUT-FOR-PCL-OBJ-P" + "WRAPPER-BITMAP" + "WRAPPER-CLASSOID-NAME" + "WRAPPER-DEPTHOID" "WRAPPER-EQUALP-IMPL" + "WRAPPER-SLOT-TABLE" + "WRAPPER-FRIEND" "LAYOUT-FRIEND" + #+(or x86-64 x86) "%LEA" + "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" + "LIST-ABSTRACT-TYPE-FUNCTION" + "LIST-COPY-SEQ*" + "LIST-FILL*" + "LIST-SUBSEQ*" + "ANSI-STREAM" + "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" + "ANSI-STREAM-IN" + "ANSI-STREAM-IN-BUFFER" "ANSI-STREAM-IN-INDEX" + "ANSI-STREAM-MISC" + "ANSI-STREAM-N-BIN" + "ANSI-STREAM-OUT" "ANSI-STREAM-SOUT" + "COMPLEX-VECTOR" + "LIST-TO-VECTOR*" + "LOGICAL-HOST" "LOGICAL-HOST-DESIGNATOR" + #+long-float ("LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS" + "LONG-FLOAT-HIGH-BITS""LONG-FLOAT-LOW-BITS" + "LONG-FLOAT-MID-BITS") + "LRA" "LRA-CODE-HEADER" "LRA-P" + "MAKE-ALIEN-TYPE-TYPE" + "MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-CONS-TYPE" + "%MAKE-DOUBLE-FLOAT" + "MAKE-DOUBLE-FLOAT" "MAKE-FUN-TYPE" "MAKE-KEY-INFO" + "MAKE-LISP-OBJ" + #+long-float "MAKE-LONG-FLOAT" + "MAKE-MEMBER-TYPE" "MAKE-NULL-LEXENV" + "MAKE-EQL-TYPE" "MEMBER-TYPE-FROM-LIST" + "MAKE-NEGATION-TYPE" "TYPE-NEGATION" + "MAKE-NUMERIC-TYPE" + "MAKE-SINGLE-FLOAT" + "MAKE-UNBOUND-MARKER" + "MAKE-SHORT-VALUES-TYPE" "MAKE-SINGLE-VALUE-TYPE" + "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE" + "MAPC-MEMBER-TYPE-MEMBERS" "MAPCAR-MEMBER-TYPE-MEMBERS" + "MAXIMUM-BIGNUM-LENGTH" + "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" + "MEMBER-TYPE-SIZE" + "MODIFIED-NUMERIC-TYPE" + "MOST-NEGATIVE-EXACTLY-DOUBLE-FLOAT-FIXNUM" + "MOST-NEGATIVE-EXACTLY-SINGLE-FLOAT-FIXNUM" + "MOST-POSITIVE-EXACTLY-DOUBLE-FLOAT-FIXNUM" + "MOST-POSITIVE-EXACTLY-SINGLE-FLOAT-FIXNUM" + "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P" + "NEGATE" "NEGATION-TYPE" "NEGATION-TYPE-TYPE" + "NIL-ARRAY-ACCESSED-ERROR" + "NIL-FUN-RETURNED-ERROR" + "NON-NULL-SYMBOL-P" + "NUMERIC-CONTAGION" "NUMERIC-TYPE" + "NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP" + "NUMERIC-TYPE-EQUAL" "NUMERIC-TYPE-FORMAT" + "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P" + "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-CHARACTER-ERROR" + "OBJECT-NOT-BASE-STRING-ERROR" "OBJECT-NOT-BIGNUM-ERROR" + "OBJECT-NOT-BIT-VECTOR-ERROR" + #+sb-unicode "OBJECT-NOT-CHARACTER-STRING-ERROR" + "OBJECT-NOT-COMPLEX-ERROR" + "OBJECT-NOT-COMPLEX-FLOAT-ERROR" + "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR" + #+long-float "OBJECT-NOT-COMPLEX-LONG-FLOAT-ERROR" + "OBJECT-NOT-COMPLEX-DOUBLE-FLOAT-ERROR" + "OBJECT-NOT-COMPLEX-RATIONAL-ERROR" + ;; FIXME: It's confusing using "complex" to mean both + ;; "not on the real number line" and "not of a + ;; SIMPLE-ARRAY nature". Perhaps we could rename all the + ;; uses in the second sense as "hairy" instead? + "OBJECT-NOT-COMPLEX-VECTOR-ERROR" "OBJECT-NOT-CONS-ERROR" + "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR" + "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR" + "OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-INTEGER-ERROR" + "OBJECT-NOT-LIST-ERROR" + #+long-float "OBJECT-NOT-LONG-FLOAT-ERROR" + "OBJECT-NOT-NUMBER-ERROR" "OBJECT-NOT-RATIO-ERROR" + "OBJECT-NOT-RATIONAL-ERROR" "OBJECT-NOT-REAL-ERROR" + "OBJECT-NOT-SAP-ERROR" "OBJECT-NOT-SIGNED-BYTE-32-ERROR" + "OBJECT-NOT-SIGNED-BYTE-64-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR" + #+long-float + "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR" + #+sb-simd-pack + "OBJECT-NOT-SIMD-PACK-ERROR" + #+sb-simd-pack-256 + "OBJECT-NOT-SIMD-PACK-256-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-ERROR" + #+long-float "OBJECT-NOT-SIMPLE-ARRAY-LONG-FLOAT-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-NIL-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-SINGLE-FLOAT-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-15-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-16-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-2-ERROR" + ;; KLUDGE: 32-bit and 64-bit ports implement a different + ;; set of specialized array types. Various bits of code + ;; in SBCL assume that symbols connected to the + ;; specialized array types are exported. But there's not + ;; a good way at this point to know whether the port for + ;; which we're building is 32-bit or 64-bit. Granted, we + ;; could hardcode the particulars (or even come up with a + ;; special :64BIT feature), but that seems a little + ;; inelegant. For now, we brute-force the issue by + ;; always exporting all the names required for both + ;; 32-bit and 64-bit ports. Other bits connected to the + ;; same issue are noted throughout the code below with + ;; the tag "32/64-bit issues". --njf, 2004-08-09 + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-FIXNUM-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-31-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-4-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-63-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-64-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-7-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-8-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-16-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-FIXNUM-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-32-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-64-ERROR" + "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-8-ERROR" + "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR" + "OBJECT-NOT-SIMPLE-BASE-STRING-ERROR" + #+sb-unicode "OBJECT-NOT-SIMPLE-CHARACTER-STRING-ERROR" + "OBJECT-NOT-SIMPLE-STRING-ERROR" + "OBJECT-NOT-SIMPLE-VECTOR-ERROR" + "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR" + "OBJECT-NOT-SYMBOL-ERROR" + "OBJECT-NOT-TYPE-ERROR" + "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR" + "OBJECT-NOT-UNSIGNED-BYTE-64-ERROR" + "OBJECT-NOT-VECTOR-ERROR" + "OBJECT-NOT-VECTOR-NIL-ERROR" + "OBJECT-NOT-WEAK-POINTER-ERROR" + "ODD-KEY-ARGS-ERROR" "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT" + "PACKAGE-DESIGNATOR" "PACKAGE-DOC-STRING" + "PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE" + "PACKAGE-INTERNAL-SYMBOLS" "PACKAGE-EXTERNAL-SYMBOLS" + "PARSE-UNKNOWN-TYPE" + "PARSE-UNKNOWN-TYPE-SPECIFIER" + "PATHNAME-DESIGNATOR" "PATHNAME-COMPONENT-CASE" + "POINTER-HASH" + "POINTERP" + #+(or x86 x86-64) "*PSEUDO-ATOMIC-BITS*" + "PUNT-PRINT-IF-TOO-LONG" + "RANDOM-DOCUMENTATION" + "READER-IMPOSSIBLE-NUMBER-ERROR" + "READER-EOF-ERROR" + "RESTART-DESIGNATOR" + "RUN-PENDING-FINALIZERS" + "SCALE-DOUBLE-FLOAT" + #+long-float "SCALE-LONG-FLOAT" + "SCALE-SINGLE-FLOAT" + "SCHWARTZIAN-STABLE-SORT-LIST" "SCHWARTZIAN-STABLE-SORT-VECTOR" + "SCRUB-POWER-CACHE" + "SEQUENCEP" "SEQUENCE-COUNT" "SEQUENCE-END" + "SEQUENCE-OF-CHECKED-LENGTH-GIVEN-TYPE" + "SET-ARRAY-HEADER" "SET-HEADER-DATA" + "ASSIGN-VECTOR-FLAGS" "LOGIOR-HEADER-BITS" "RESET-HEADER-BITS" + "LOGIOR-ARRAY-FLAGS" "RESET-ARRAY-FLAGS" + "TEST-HEADER-BIT" + "SHIFT-TOWARDS-END" + "SHIFT-TOWARDS-START" "SHRINK-VECTOR" "%SHRINK-VECTOR" + "SIGNED-BYTE-32-P" "SIGNED-BYTE-64-P" + "SIMPLE-RANK-1-ARRAY-*-P" + "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-P" + #+long-float "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-P" + "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-P" + "SIMPLE-ARRAY-DOUBLE-FLOAT-P" + #+long-float "SIMPLE-ARRAY-LONG-FLOAT-P" + "SIMPLE-ARRAY-NIL-P" "SIMPLE-ARRAY-P" + "SIMPLE-ARRAY-SINGLE-FLOAT-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-15-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-16-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-2-P" + "SIMPLE-ARRAY-UNSIGNED-FIXNUM-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-31-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-32-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-4-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-63-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-64-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-7-P" + "SIMPLE-ARRAY-UNSIGNED-BYTE-8-P" + "SIMPLE-ARRAY-SIGNED-BYTE-16-P" + "SIMPLE-ARRAY-FIXNUM-P" + "SIMPLE-ARRAY-SIGNED-BYTE-32-P" + "SIMPLE-ARRAY-SIGNED-BYTE-64-P" + "SIMPLE-ARRAY-SIGNED-BYTE-8-P" "SIMPLE-BASE-STRING-P" + "SIMPLE-CHARACTER-STRING" + #+sb-unicode "SIMPLE-CHARACTER-STRING-P" + "SIMPLE-PACKAGE-ERROR" "SIMPLE-UNBOXED-ARRAY" + "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT" + "SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-SIGNIFICAND" + "SINGLE-FLOAT-SIGN" "SINGLE-FLOAT-COPYSIGN" + "SINGLE-VALUE-TYPE" "SINGLE-VALUE-SPECIFIER-TYPE" + "SPECIFIER-TYPE" + #+sb-simd-pack("SIMD-PACK-SINGLE" + "SIMD-PACK-DOUBLE" + "SIMD-PACK-INT" + "SIMD-PACK-TYPE" + "SIMD-PACK-TYPE-ELEMENT-TYPE" + "*SIMD-PACK-ELEMENT-TYPES*") + #+sb-simd-pack-256("SIMD-PACK-256-SINGLE" + "SIMD-PACK-256-DOUBLE" + "SIMD-PACK-256-INT" + "SIMD-PACK-256-TYPE" + "SIMD-PACK-256-TYPE-ELEMENT-TYPE") + "STACK-REF" "STREAM-DESIGNATOR" "STRING-DESIGNATOR" + "STRING-FILL*" + "STRUCT-SLOT-SAP" + "STRUCTURE-CTOR-LAMBDA-PARTS" + "STRUCTURE-INSTANCE-ACCESSOR-P" + "SUB-GC" + "SYMBOL-TLS-INDEX" + "SYMBOLS-DESIGNATOR" + "SYMEVAL" + "SYM-GLOBAL-VAL" + "%INSTANCE-LENGTH" + "%INSTANCE-REF" "%INSTANCE-REF-EQ" + "%INSTANCE-SET" + "TESTABLE-TYPE-P" + "TLS-EXHAUSTED-ERROR" + "*TOP-LEVEL-FORM-P*" + "TWO-ARG-*" "TWO-ARG-+" "TWO-ARG--" "TWO-ARG-/" + "TWO-ARG-/=" "TWO-ARG-<" "TWO-ARG-<=" "TWO-ARG-=" + "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND" "TWO-ARG-EQV" + "TWO-ARG-GCD" "TWO-ARG-IOR" "TWO-ARG-LCM" "TWO-ARG-XOR" + "TWO-ARG-STRING=" "TWO-ARG-STRING-EQUAL" "TWO-ARG-STRING<" + "TWO-ARG-STRING>" "TWO-ARG-STRING<=" "TWO-ARG-STRING>=" + "TWO-ARG-STRING/=" "TWO-ARG-STRING-LESSP" "TWO-ARG-STRING-GREATERP" + "TWO-ARG-STRING-NOT-LESSP" "TWO-ARG-STRING-NOT-GREATERP" "TWO-ARG-STRING-NOT-EQUAL" + "TYPE-*-TO-T" + "TYPE-DIFFERENCE" "TYPE-INTERSECTION" + "TYPE-INTERSECTION2" "TYPE-APPROX-INTERSECTION2" + "TYPE-SINGLETON-P" + "TYPE-SINGLE-VALUE-P" "TYPE-SPECIFIER" "TYPE-UNION" + "TYPE/=" "TYPE=" "TYPES-EQUAL-OR-INTERSECT" + "TYPE-OR-NIL-IF-UNKNOWN" + "TYPE-ERROR-DATUM-STORED-TYPE" + "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY" + "UNDEFINED-FUN-ERROR" "UNDEFINED-ALIEN-FUN-ERROR" + "UNION-TYPE" "UNION-TYPE-P" + "UNION-TYPE-TYPES" "UNKNOWN-ERROR" + "UNINITIALIZED-ELEMENT-ERROR" ; for Lisp arrays + "UNINITIALIZED-MEMORY-ERROR" ; for SAPs + "UNKNOWN-KEY-ARG-ERROR" "UNKNOWN-TYPE" "UNKNOWN-TYPE-P" + "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR" + "UNSIGNED-BYTE-32-P" "UNSIGNED-BYTE-64-P" + "UPDATE-OBJECT-LAYOUT" + "VALID-MACROEXPAND-HOOK" + "VALUE-CELL-REF" "VALUE-CELL-SET" "VALUES-SPECIFIER-TYPE" + "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP" + "VALUES-TYPE" "VALUES-TYPE-IN" + "VALUES-TYPE-INTERSECTION" + "VALUES-TYPE-MIN-VALUE-COUNT" "VALUES-TYPE-MAX-VALUE-COUNT" + "VALUES-TYPE-MAY-BE-SINGLE-VALUE-P" "VALUES-TYPE-OPTIONAL" + "VALUES-TYPE-OUT" "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED" + "VALUES-TYPE-REST" "VALUES-TYPE-UNION" + "VALUES-TYPE-TYPES" "VALUES-TYPES" + "VALUES-TYPES-EQUAL-OR-INTERSECT" + + "*VECTOR-WITHOUT-COMPLEX-TYPECODE-INFOS*" + "VECTOR-SINGLE-FLOAT-P" "VECTOR-DOUBLE-FLOAT-P" + "VECTOR-UNSIGNED-BYTE-2-P" "VECTOR-UNSIGNED-BYTE-4-P" + "VECTOR-UNSIGNED-BYTE-7-P" "VECTOR-UNSIGNED-BYTE-8-P" + "VECTOR-UNSIGNED-BYTE-15-P" "VECTOR-UNSIGNED-BYTE-16-P" + "VECTOR-UNSIGNED-BYTE-31-P" "VECTOR-UNSIGNED-BYTE-32-P" + "VECTOR-UNSIGNED-BYTE-63-P" "VECTOR-UNSIGNED-BYTE-64-P" + "VECTOR-SIGNED-BYTE-8-P" "VECTOR-SIGNED-BYTE-16-P" + "VECTOR-FIXNUM-P" "VECTOR-SIGNED-BYTE-32-P" + "VECTOR-SIGNED-BYTE-64-P" "VECTOR-COMPLEX-SINGLE-FLOAT-P" + "VECTOR-COMPLEX-DOUBLE-FLOAT-P" "VECTOR-T-P" + + "VECTOR-NIL-P" + "VECTOR-FILL*" "VECTOR-FILL/T" + "VECTOR-SUBSEQ*" + "VECTOR-TO-VECTOR*" + "VECTOR-OF-CHECKED-LENGTH-GIVEN-LENGTH" "WITH-ARRAY-DATA" + "WITH-CIRCULARITY-DETECTION" + "WITH-WORLD-LOCK" + + ;; bit bash fillers + "UB1-BASH-FILL" + "UB2-BASH-FILL" + "UB4-BASH-FILL" + "UB8-BASH-FILL" + "UB16-BASH-FILL" + "UB32-BASH-FILL" + "UB64-BASH-FILL" + + "UB1-BASH-FILL-WITH-UB1" "UB1-BASH-FILL-WITH-SB1" + "UB2-BASH-FILL-WITH-UB2" "UB2-BASH-FILL-WITH-SB2" + "UB4-BASH-FILL-WITH-UB4" "UB4-BASH-FILL-WITH-SB4" + "UB8-BASH-FILL-WITH-UB8" "UB8-BASH-FILL-WITH-SB8" + "UB16-BASH-FILL-WITH-UB16" "UB16-BASH-FILL-WITH-SB16" + "UB32-BASH-FILL-WITH-UB32" "UB32-BASH-FILL-WITH-SB32" + "UB64-BASH-FILL-WITH-SB64" + "UB32-BASH-FILL-WITH-FIXNUM" "UB64-BASH-FILL-WITH-FIXNUM" + "UB32-BASH-FILL-WITH-SINGLE-FLOAT" + "UB64-BASH-FILL-WITH-DOUBLE-FLOAT" + "UB64-BASH-FILL-WITH-COMPLEX-SINGLE-FLOAT" + + ;; bit bash copiers + "SYSTEM-AREA-UB8-COPY" + "COPY-UB8-TO-SYSTEM-AREA" "COPY-UB8-FROM-SYSTEM-AREA" + "UB1-BASH-COPY" + "UB2-BASH-COPY" + "UB4-BASH-COPY" + "UB8-BASH-COPY" + "UB16-BASH-COPY" + "UB32-BASH-COPY" + "UB64-BASH-COPY" + + ;; Bit bashing position for bit-vectors + "%BIT-POSITION" "%BIT-POS-FWD" "%BIT-POS-REV" + "%BIT-POSITION/0" "%BIT-POS-FWD/0" "%BIT-POS-REV/0" + "%BIT-POSITION/1" "%BIT-POS-FWD/1" "%BIT-POS-REV/1" + + ;; SIMPLE-FUN type and accessors + "SIMPLE-FUN" + "SIMPLE-FUN-P" + "%SIMPLE-FUN-ARGLIST" + "%SIMPLE-FUN-DOC" + "%SIMPLE-FUN-INFO" + "%SIMPLE-FUN-LEXPR" + "%SIMPLE-FUN-NAME" + "%SIMPLE-FUN-TEXT-LEN" + "%SIMPLE-FUN-SOURCE" + "%SIMPLE-FUN-TYPE" + "%SIMPLE-FUN-XREFS" + + ;; CLOSURE type and accessors + "CLOSURE" + "CLOSUREP" + "DO-CLOSURE-VALUES" + "%CLOSURE-FUN" + "%CLOSURE-INDEX-REF" + "%CLOSURE-INDEX-SET" + "%CLOSURE-VALUES" + + ;; Abstract function accessors + "%FUN-FUN" + "%FUN-LAMBDA-LIST" + "%FUN-NAME" + + "FDEFN" "MAKE-FDEFN" "FDEFN-P" "FDEFN-NAME" "FDEFN-FUN" + "FDEFN-MAKUNBOUND" + "%COERCE-CALLABLE-TO-FUN" + "%COERCE-CALLABLE-FOR-CALL" + "%FUN-POINTER-WIDETAG" + "*MAXIMUM-ERROR-DEPTH*" "%SET-SYMBOL-PLIST" + "INFINITE-ERROR-PROTECT" + "FIND-CALLER-OF-NAMED-FRAME" + "FIND-CALLER-FRAME" + "FIND-INTERRUPTED-FRAME" + "%SET-SYMBOL-VALUE" "%SET-SYMBOL-GLOBAL-VALUE" "%SET-SYMBOL-PACKAGE" + "SET-SYMBOL-GLOBAL-VALUE" + "OUTPUT-SYMBOL" "%COERCE-NAME-TO-FUN" + "DEFAULT-STRUCTURE-PRINT" + "WRAPPER" "WRAPPER-LENGTH" + "DEFSTRUCT-DESCRIPTION" "UNDECLARE-STRUCTURE" + "UNDEFINE-FUN-NAME" "DD-TYPE" "CLASSOID-STATE" "INSTANCE" + "*TYPE-SYSTEM-INITIALIZED*" "FIND-LAYOUT" + "%TYPEP" "%%TYPEP" "DD-NAME" "CLASSOID-SUBCLASSES" + "CLASSOID-LAYOUT" "CLASSOID-NAME" "CLASSOID-P" "CLASSOID-WRAPPER" + "NOTE-NAME-DEFINED" + "%CODE-CODE-SIZE" "%CODE-TEXT-SIZE" + "%CODE-SERIALNO" + "DD-SLOTS" "DD-INCLUDE" "SLOT-SETTER-LAMBDA-FORM" + "SLOT-ACCESS-TRANSFORM" + "%IMAGPART" "%CODE-DEBUG-INFO" + "WRAPPER-CLASSOID" "WRAPPER-INVALID" + "WRAPPER-FLAGS" + "LAYOUT-FLAGS" + "%INSTANCEP" "DEFSTRUCT-SLOT-DESCRIPTION" + "DD-PREDICATE-NAME" + "CLASSOID-PROPER-NAME" "%NOTE-TYPE-DEFINED" "WRAPPER-INFO" + "WRAPPER-DD" + "%SET-INSTANCE-LAYOUT" + "DD-CONSTRUCTORS" "DD-DEFAULT-CONSTRUCTOR" + "WRAPPER-OF" + "%REALPART" + "STRUCTURE-CLASSOID" "STRUCTURE-CLASSOID-P" + "GET-DSD-INDEX" + "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "%INSTANCEOID-LAYOUT" + "WRAPPER-CLOS-HASH" + "%INSTANCE-WRAPPER" "%FUN-WRAPPER" + "PROCLAIM-AS-FUN-NAME" "BECOME-DEFINED-FUN-NAME" + "%NUMERATOR" "CLASSOID-TYPEP" + "WRAPPER-INHERITS" "DD-LENGTH" + "SET-LAYOUT-INHERITS" + "%CODE-ENTRY-POINT" + "%CODE-FUN-OFFSET" + "CODE-N-ENTRIES" + "CODE-N-NAMED-CALLS" + "CODE-OBJ-IS-FILLER-P" + "%DENOMINATOR" + "%OTHER-POINTER-P" + "%OTHER-POINTER-SUBTYPE-P" + "IMMOBILE-SPACE-ADDR-P" + "IMMOBILE-SPACE-OBJ-P" + + "STANDARD-CLASSOID" "CLASSOID-OF" + "MAKE-STANDARD-CLASSOID" + "CLASSOID-CELL-CLASSOID" + "CLASSOID-CELL-NAME" + "CLASSOID-CELL-PCL-CLASS" + "CLASSOID-CELL-TYPEP" + "%CLEAR-CLASSOID" + "FIND-CLASSOID-CELL" + "%RANDOM-DOUBLE-FLOAT" + #+long-float "%RANDOM-LONG-FLOAT" + "%RANDOM-SINGLE-FLOAT" "STATIC-CLASSOID" + "%FUNCALLABLE-INSTANCE-INFO" "RANDOM-CHUNK" "BIG-RANDOM-CHUNK" + "N-RANDOM-CHUNK-BITS" + "BUILT-IN-CLASSOID-DIRECT-SUPERCLASSES" + "BUILT-IN-CLASSOID-TRANSLATION" "HASH-LAYOUT-NAME" + "CLASSOID-PCL-CLASS" "FUNCALLABLE-STRUCTURE" + "FUNCTION-WITH-LAYOUT-P" + "%FUN-LAYOUT" "%SET-FUN-LAYOUT" + "REGISTER-LAYOUT" + "FUNCALLABLE-INSTANCE" + "MAKE-STATIC-CLASSOID" + "%MAKE-SYMBOL" + "%FUNCALLABLE-INSTANCE-FUN" "SYMBOL-HASH" "SYMBOL-HASH*" + "SYMBOL-%INFO" "SYMBOL-DBINFO" "%INFO-REF" + + "EXTENDED-SEQUENCE" "*EXTENDED-SEQUENCE-TYPE*" + "EXTENDED-SEQUENCE-P" + + "BUILT-IN-CLASSOID" "CONDITION-CLASSOID-P" + "CONDITION-CLASSOID-SLOTS" "MAKE-UNDEFINED-CLASSOID" + "FIND-CLASSOID" "CLASSOID" "CLASSOID-DIRECT-SUPERCLASSES" + "MAKE-LAYOUT" + "INSURED-FIND-CLASSOID" "ORDER-LAYOUT-INHERITS" + "STD-COMPUTE-CLASS-PRECEDENCE-LIST" + "+STRUCTURE-LAYOUT-FLAG+" + "+PCL-OBJECT-LAYOUT-FLAG+" + "+CONDITION-LAYOUT-FLAG+" + "+PATHNAME-LAYOUT-FLAG+" + "+STREAM-LAYOUT-FLAG+" + "+SIMPLE-STREAM-LAYOUT-FLAG+" + "+FILE-STREAM-LAYOUT-FLAG+" + "+STRING-STREAM-LAYOUT-FLAG+" + "+SEQUENCE-LAYOUT-FLAG+" + "+LAYOUT-ALL-TAGGED+" + "**PRIMITIVE-OBJECT-LAYOUTS**" + + "*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*" + "WITH-SIMPLE-CONDITION-RESTARTS" + "CASE-FAILURE" "ECASE-FAILURE" "ETYPECASE-FAILURE" + "NAMESTRING-PARSE-ERROR" + "NAMESTRING-PARSE-ERROR-OFFSET" + "NO-NAMESTRING-ERROR" "NO-NATIVE-NAMESTRING-ERROR" + "MAKE-RESTART" "RESTART-ASSOCIATED-CONDITIONS" + "COERCE-TO-CONDITION" + + "ALLOCATE-CONDITION" + + "CONDITION-SLOT-VALUE" + "SET-CONDITION-SLOT-VALUE" + + "CONDITION-SLOT-ALLOCATION" + "CONDITION-SLOT-DOCUMENTATION" + "CONDITION-SLOT-INITARGS" + "CONDITION-SLOT-INITFORM" + "CONDITION-SLOT-INITFORM-P" + "CONDITION-SLOT-INITFUNCTION" + "CONDITION-SLOT-NAME" "CONDITION-SLOT-READERS" + "CONDITION-SLOT-WRITERS" + + "REDEFINITION-WARNING" + "REDEFINITION-WITH-DEFUN" + "REDEFINITION-WITH-DEFMACRO" + "REDEFINITION-WITH-DEFGENERIC" + "REDEFINITION-WITH-DEFMETHOD" + "UNINTERESTING-ORDINARY-FUNCTION-REDEFINITION-P" + "UNINTERESTING-GENERIC-FUNCTION-REDEFINITION-P" + "UNINTERESTING-METHOD-REDEFINITION-P" + "UNINTERESTING-REDEFINITION" + "REDEFINITION-WITH-DEFTRANSFORM" + + "DUBIOUS-ASTERISKS-AROUND-VARIABLE-NAME" + "ASTERISKS-AROUND-LEXICAL-VARIABLE-NAME" + "ASTERISKS-AROUND-CONSTANT-VARIABLE-NAME" + "&OPTIONAL-AND-&KEY-IN-LAMBDA-LIST" + "UNDEFINED-ALIEN-STYLE-WARNING" + "LEXICAL-ENVIRONMENT-TOO-COMPLEX" + "CHARACTER-DECODING-ERROR-IN-COMMENT" + "DEPRECATED-EVAL-WHEN-SITUATIONS" + "PROCLAMATION-MISMATCH" + "PROCLAMATION-MISMATCH-NAME" + "PROCLAMATION-MISMATCH-NEW" + "PROCLAMATION-MISMATCH-OLD" + "TYPE-PROCLAMATION-MISMATCH" + "TYPE-PROCLAMATION-MISMATCH-WARNING" + "TYPE-PROCLAMATION-MISMATCH-WARN" + "FTYPE-PROCLAMATION-MISMATCH" + "FTYPE-PROCLAMATION-MISMATCH-WARNING" + "FTYPE-PROCLAMATION-MISMATCH-WARN" + "FTYPE-PROCLAMATION-MISMATCH-ERROR" + + "!COLD-INIT" + "!TYPE-CLASS-COLD-INIT" + "!CLASSES-COLD-INIT" + "!TYPE-COLD-INIT" + "!FIXUP-TYPE-COLD-INIT" + "!RANDOM-COLD-INIT" + "!LOADER-COLD-INIT" + "!POLICY-COLD-INIT-OR-RESANIFY" + "!LATE-PROCLAIM-COLD-INIT" "!CLASS-FINALIZE" + + "FLOAT-COLD-INIT-OR-REINIT" + "GC-REINIT" + "TIME-REINIT" + "SIGNAL-COLD-INIT-OR-REINIT" + "STREAM-COLD-INIT-OR-RESET" + + ;; Cleanups to run before saving a core + "FLOAT-DEINIT" + "FOREIGN-DEINIT" + "PROFILE-DEINIT" + + ;; Note: These are out of lexicographical order + ;; because in CMU CL they were defined as + ;; internal symbols in package "CL" imported + ;; into package "C", as opposed to what we're + ;; doing here, defining them as external symbols + ;; in a package which is used by both "SB-C" and + ;; "SB-IMPL". (SBCL's "SB-C" is directly + ;; analogous to CMU CL's "C"; and for this + ;; purpose, SBCL's "SB-IMPL" is analogous to CMU + ;; CL's "CL".) As far as I know there's nothing + ;; special about them, so they could be merged + ;; into the same order as everything else in the + ;; in this package. -- WHN 19990911 + "STRING>=*" "STRING>*" "STRING=*" "STRING<=*" + "STRING<*" "STRING/=*" "%SVSET" + "%SP-STRING-COMPARE" "%SETNTH" "%SETELT" + "%SET-ROW-MAJOR-AREF" "%SET-FILL-POINTER" + "%SET-FDEFINITION" "%SCHARSET" + "%RPLACD" "%RPLACA" "%PUT" "%CHARSET" + "%WITH-OUTPUT-TO-STRING")) + + #s(sb-cold:package-data + :name "SB-THREAD" + :use ("CL" "SB-ALIEN" "SB-INT" "SB-SYS" "SB-KERNEL") + :doc "public (but low-level): native thread support" + :export ("*CURRENT-THREAD*" + "DESTROY-THREAD" + "INTERRUPT-THREAD" + "INTERRUPT-THREAD-ERROR" + "INTERRUPT-THREAD-ERROR-THREAD" + "RETURN-FROM-THREAD" + "ABORT-THREAD" + "MAIN-THREAD-P" + "MAIN-THREAD" + "JOIN-THREAD" + "JOIN-THREAD-ERROR" + "JOIN-THREAD-ERROR-THREAD" + "LIST-ALL-THREADS" + "MAKE-THREAD" + "SYMBOL-VALUE-IN-THREAD" + "SYMBOL-VALUE-IN-THREAD-ERROR" + "TERMINATE-THREAD" + "THREAD" + "THREAD-DEADLOCK" + "THREAD-DEADLOCK-CYCLE" + "THREAD-ERROR" + "THREAD-ERROR-THREAD" + "THREAD-ALIVE-P" + "THREAD-EPHEMERAL-P" + "THREAD-NAME" + "THREAD-OS-TID" + "THREAD-YIELD" + "FOREIGN-THREAD" + ;; Memory barrier + "BARRIER" + ;; Mutexes + "GET-MUTEX" + "GRAB-MUTEX" + "HOLDING-MUTEX-P" + "MAKE-MUTEX" + "MUTEX" + "MUTEX-NAME" + "MUTEX-OWNER" + "MUTEX-VALUE" + "RELEASE-MUTEX" + "WITH-MUTEX" + "WITH-RECURSIVE-LOCK" + ;; Condition variables + "CONDITION-BROADCAST" + "CONDITION-NOTIFY" + "CONDITION-WAIT" + "MAKE-WAITQUEUE" + "WAITQUEUE" + "WAITQUEUE-NAME" + ;; Sessions + "MAKE-LISTENER-THREAD" + "RELEASE-FOREGROUND" + "WITH-NEW-SESSION" + ;; Semaphores + "MAKE-SEMAPHORE" + "SEMAPHORE" + "SEMAPHORE-NAME" + "SEMAPHORE-COUNT" + "SIGNAL-SEMAPHORE" + "TRY-SEMAPHORE" + "WAIT-ON-SEMAPHORE" + ;; Semaphore notification objects + "CLEAR-SEMAPHORE-NOTIFICATION" + "MAKE-SEMAPHORE-NOTIFICATION" + "SEMAPHORE-NOTIFICATION" + "SEMAPHORE-NOTIFICATION-STATUS")) + + #s(sb-cold:package-data + :name "SB-LOOP" + :doc "private: implementation details of LOOP" + :use ("CL" "SB-INT" "SB-KERNEL") + :export ()) + + #s(sb-cold:package-data + :name "SB-MOP" + :doc + "public: the MetaObject Protocol interface, as defined by +The Art of the Metaobject Protocol, by Kiczales, des Rivieres and Bobrow: +ISBN 0-262-61074-4, with exceptions as noted in the User Manual." + :use ("CL") + :reexport ("ADD-METHOD" + "ALLOCATE-INSTANCE" + "CLASS-NAME" "COMPUTE-APPLICABLE-METHODS" + "ENSURE-GENERIC-FUNCTION" "MAKE-INSTANCE" + "METHOD-QUALIFIERS" "REMOVE-METHOD" + "BUILT-IN-CLASS" "CLASS" + "FUNCTION" "GENERIC-FUNCTION" + "METHOD" "METHOD-COMBINATION" + "STANDARD-CLASS" "STANDARD-GENERIC-FUNCTION" + "STANDARD-METHOD" "STANDARD-OBJECT" "T") + :export ("ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FORWARD-REFERENCED-CLASS" + "FUNCALLABLE-STANDARD-CLASS" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "FUNCALLABLE-STANDARD-OBJECT" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METAOBJECT" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-SPECIALIZERS" + "ACCESSOR-METHOD-SLOT-DEFINITION" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-DEFINITION" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-LOCATION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-WRITERS" + "SLOT-DEFINITION-TYPE" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-ACCESSOR-METHOD" + "STANDARD-DIRECT-SLOT-DEFINITION" + "STANDARD-EFFECTIVE-SLOT-DEFINITION" + "STANDARD-INSTANCE-ACCESS" + "STANDARD-READER-METHOD" + "STANDARD-SLOT-DEFINITION" + "STANDARD-WRITER-METHOD" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS")) + + #s(sb-cold:package-data + :name "SB-REGALLOC" + :doc "private: implementation of the compiler's register allocator" + :use ("CL" "SB-ALIEN-INTERNALS" "SB-ALIEN" "SB-ASSEM" "SB-BIGNUM" + #+sb-dyncount "SB-DYNCOUNT" "SB-EXT" "SB-FASL" "SB-INT" + "SB-KERNEL" "SB-SYS" + "SB-C") + :import-from (("SB-C" + "*LOOP-ANALYZE*" + "BLOCK-INFO" "BLOCK-LAST" "BLOCK-LOOP" "BLOCK-NEXT" + "CLEAR-BIT-VECTOR" "COMPONENT-HEAD" "COMPONENT-TAIL" + "DEFEVENT" "DELETE-VOP" "DO-IR2-BLOCKS" "DO-LIVE-TNS" + "EMIT-LOAD-TEMPLATE" "EVENT" "FIND-IN" + "FINITE-SB" "FINITE-SB-ALWAYS-LIVE" + "FINITE-SB-WIRED-MAP" "FINITE-SB-CONFLICTS" + "FINITE-SB-CURRENT-SIZE" "FINITE-SB-LAST-BLOCK-COUNT" + "FINITE-SB-LAST-OFFSET" "FINITE-SB-LIVE-TNS" + "FINITE-SB-SIZE-ALIGNMENT" "FINITE-SB-SIZE-INCREMENT" + "GET-OPERAND-INFO" "GLOBAL-CONFLICTS-BLOCK" + "GLOBAL-CONFLICTS-CONFLICTS" "GLOBAL-CONFLICTS-KIND" + "GLOBAL-CONFLICTS-NEXT-TNWISE" "GLOBAL-CONFLICTS-NUMBER" + "GLOBAL-CONFLICTS-NEXT-BLOCKWISE" "GLOBAL-CONFLICTS-TN" + "IR2-BLOCK" "IR2-BLOCK-COUNT" "IR2-BLOCK-GLOBAL-TNS" + "IR2-BLOCK-LAST-VOP" "IR2-BLOCK-LIVE-IN" + "IR2-BLOCK-LOCAL-TN-COUNT" "IR2-BLOCK-LOCAL-TNS" + "IR2-BLOCK-NEXT" "IR2-BLOCK-NUMBER" "IR2-BLOCK-PREV" + "IR2-BLOCK-START-VOP" "IR2-COMPONENT" + "IR2-COMPONENT-GLOBAL-TN-COUNTER" + "IR2-COMPONENT-NORMAL-TNS" "IR2-COMPONENT-RESTRICTED-TNS" + "IR2-COMPONENT-SPILLED-TNS" "IR2-COMPONENT-SPILLED-VOPS" + "IR2-COMPONENT-WIRED-TNS" + "LAMBDA-PARENT" "LEXENV-LAMBDA" "LISTIFY-RESTRICTIONS" + "LOCAL-TN-BIT-VECTOR" "LOCAL-TN-COUNT" "LOCAL-TN-LIMIT" + "LOCAL-TN-NUMBER" "LOCAL-TN-VECTOR" + "LOOP-DEPTH" "MAKE-TN" "MOVE-OPERAND" "NODE" "NODE-LEXENV" + "OPERAND-PARSE-NAME" "POSITION-IN" + "PRIMITIVE-TYPE-SCS" "PRINT-TN-GUTS" + "SB-KIND" "SB-SIZE" + "SC-LOCATIONS" "MAKE-SC-LOCATIONS" "SC-OFFSET-TO-SC-LOCATIONS" + "SC-LOCATIONS-COUNT" "SC-LOCATIONS-FIRST" "SC-LOCATIONS-MEMBER" + "DO-SC-LOCATIONS" + "SC-ALIGNMENT" "SC-ALLOWED-BY-PRIMITIVE-TYPE" + "SC-ALTERNATE-SCS" "SC-CONSTANT-SCS" "SC-ELEMENT-SIZE" + "SC-LOCATIONS" "SC-MOVE-FUNS" "SC-RESERVE-LOCATIONS" + "SC-SAVE-P" "SC-VECTOR" + "SET-BIT-VECTOR" + "TEMPLATE-NAME" + "TN" "TN-COST" "TN-GLOBAL-CONFLICTS" "TN-KIND" "TN-LEAF" + "TN-LOCAL" "TN-LOCAL-CONFLICTS" "TN-LOCAL-NUMBER" + "TN-NEXT" "TN-NUMBER" "TN-PRIMITIVE-TYPE" + "TN-READS" "TN-SAVE-TN" "TN-VERTEX" "TN-WRITES" + "TNS-CONFLICT" "TNS-CONFLICT-GLOBAL-GLOBAL" + "TNS-CONFLICT-LOCAL-GLOBAL" + "VOP" "VOP-ARGS" "VOP-INFO" "VOP-INFO-ARG-LOAD-SCS" + "VOP-INFO-MOVE-ARGS" "VOP-NAME" + "VOP-INFO-RESULT-LOAD-SCS" "VOP-INFO-SAVE-P" + "VOP-NODE" + "VOP-PARSE-OR-LOSE" "VOP-PARSE-TEMPS" "VOP-PREV" + "VOP-REFS" "VOP-RESULTS" "VOP-SAVE-SET" "VOP-TEMPS")) + :export ("PACK" "TARGET-IF-DESIRABLE" "*REGISTER-ALLOCATION-METHOD*" + "*PACK-ITERATIONS*" + "*PACK-ASSIGN-COSTS*" "*PACK-OPTIMIZE-SAVES*" + "*TN-WRITE-COST*" "*TN-LOOP-DEPTH-MULTIPLIER*")) + + #s(sb-cold:package-data + :name "SB-PCL" + :doc + "semi-public: This package includes useful meta-object protocol +extensions, but even they are not guaranteed to be present in later +versions of SBCL, and the other stuff in here is definitely not +guaranteed to be present in later versions of SBCL. Use of this +package is deprecated in favour of SB-MOP." + :use ("CL" "SB-MOP" "SB-INT" "SB-EXT" "SB-WALKER" "SB-KERNEL") + ;; experimental SBCL-only (for now) symbols + :export ("SYSTEM-CLASS" + + "MAKE-METHOD-LAMBDA-USING-SPECIALIZERS" + "MAKE-METHOD-SPECIALIZERS-FORM" + + "SPECIALIZER-TYPE-SPECIFIER" + "MAKE-SPECIALIZER-FORM-USING-CLASS" + "PARSE-SPECIALIZER-USING-CLASS" + "UNPARSE-SPECIALIZER-USING-CLASS" + + "+SLOT-UNBOUND+" + + "ENSURE-CLASS-FINALIZED" + + "ILLEGAL-CLASS-NAME-ERROR" + "CLASS-NOT-FOUND-ERROR" + "SPECIALIZER-NAME-SYNTAX-ERROR")) + + #s(sb-cold:package-data + :name "SB-PRETTY" + :doc "private: implementation of pretty-printing" + :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") + :export ("PRETTY-STREAM" "PRETTY-STREAM-P" + "PPRINT-DISPATCH-TABLE" + "*PPRINT-QUOTE-WITH-SYNTACTIC-SUGAR*" + "!PPRINT-COLD-INIT")) + + #s(sb-cold:package-data + :name "SB-PROFILE" + :doc "public: the interface to the profiler" + :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL") + :export ("PROFILE" "REPORT" "RESET" "UNPROFILE")) + + #s(sb-cold:package-data + :name "SB-APROF" + :doc "public: the interface to the deterministic consing profiler" + :use ("CL" "SB-EXT" "SB-INT" "SB-KERNEL" "SB-ALIEN" "SB-SYS")) + + #s(sb-cold:package-data + :name "SB-SEQUENCE" + :doc "semi-public: implements something which might eventually +be submitted as a CDR" + :use () + :export ("PROTOCOL-UNIMPLEMENTED" + "PROTOCOL-UNIMPLEMENTED-OPERATION" + + "DOSEQUENCE" + + "MAKE-SEQUENCE-ITERATOR" "MAKE-SIMPLE-SEQUENCE-ITERATOR" + + "ITERATOR-STEP" "ITERATOR-ENDP" "ITERATOR-ELEMENT" + "ITERATOR-INDEX" "ITERATOR-COPY" + + "WITH-SEQUENCE-ITERATOR" "WITH-SEQUENCE-ITERATOR-FUNCTIONS" + + "CANONIZE-TEST" "CANONIZE-KEY" + + "EMPTYP" "LENGTH" "ELT" + "MAKE-SEQUENCE-LIKE" "ADJUST-SEQUENCE" + + "MAP" + "COUNT" "COUNT-IF" "COUNT-IF-NOT" + "FIND" "FIND-IF" "FIND-IF-NOT" + "POSITION" "POSITION-IF" "POSITION-IF-NOT" + "SUBSEQ" "COPY-SEQ" "FILL" + "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" + "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" + "REPLACE" "REVERSE" "NREVERSE" "CONCATENATE" "REDUCE" + "MISMATCH" "SEARCH" + "DELETE" "DELETE-IF" "DELETE-IF-NOT" + "REMOVE" "REMOVE-IF" "REMOVE-IF-NOT" + "DELETE-DUPLICATES" "REMOVE-DUPLICATES" + + "SORT" "STABLE-SORT" "MERGE")) + + #s(sb-cold:package-data + :name "SB-SYS" + :doc + "private: In theory, this \"contains functions and information +necessary for system interfacing\" (said cmu-user.tex at the time +of the SBCL code fork). That probably was and is a good idea, but in +practice, the distinctions between this package and SB-KERNEL +and even SB-VM seem to have become somewhat blurred over the years. +Some anomalies (e.g. FIND-IF-IN-CLOSURE being in SB-SYS instead of +SB-KERNEL) have been undone, but probably more remain." + :use ("CL" "SB-EXT" "SB-INT") + :export (;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS + ;; is for OS-dependent stuff. %PRIMITIVE should probably be in + ;; SB-KERNEL.) + "%PRIMITIVE" + "%STANDARD-CHAR-P" + "*EXIT-ERROR-HANDLER*" + "*EXIT-IN-PROGRESS*" + "*ALLOW-WITH-INTERRUPTS*" + "*INTERRUPTS-ENABLED*" + "*INTERRUPT-PENDING*" + #+sb-safepoint "*THRUPTION-PENDING*" + "*LINKAGE-INFO*" + "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*" + "*MACHINE-VERSION*" + "*PERIODIC-POLLING-FUNCTION*" + "*PERIODIC-POLLING-PERIOD*" + "*RUNTIME-DLHANDLE*" + "*SHARED-OBJECTS*" + "*STDERR*" "*STDIN*" + "*STDOUT*" + "*TTY*" + "ADD-FD-HANDLER" + "ALLOCATE-SYSTEM-MEMORY" + "ALLOW-WITH-INTERRUPTS" + "BEEP" + "BREAKPOINT-ERROR" + "CANCEL-DEADLINE" + "CLOSE-SHARED-OBJECTS" + "DEADLINE-TIMEOUT" + "DEALLOCATE-SYSTEM-MEMORY" + "DECODE-TIMEOUT" + "DECODE-INTERNAL-TIME" + "DEFER-DEADLINE" + "DLOPEN-OR-LOSE" + "ENABLE-INTERRUPT" + "EXTERN-ALIEN-NAME" + "EXIT-CODE" + "FD-STREAM" "FD-STREAM-FD" "FD-STREAM-P" + "FIND-DYNAMIC-FOREIGN-SYMBOL-ADDRESS" + "FIND-FOREIGN-SYMBOL-ADDRESS" + "FIND-FOREIGN-SYMBOL-IN-TABLE" + #+(and win32 x86-64) "FOREIGN-HEAP-CORRUPTION" + "FOREIGN-SYMBOL-SAP" + "FOREIGN-SYMBOL-ADDRESS" + "FOREIGN-SYMBOL-DATAREF-SAP" + "GET-MACHINE-VERSION" "GET-SYSTEM-INFO" + "IN-INTERRUPTION" + "INTERACTIVE-INTERRUPT" + "INT-SAP" + "INVALIDATE-DESCRIPTOR" + "INVOKE-INTERRUPTION" + "IO-TIMEOUT" + "MACRO" "MAKE-FD-STREAM" + "MEMORY-FAULT-ERROR" + "MEMMOVE" + "NLX-PROTECT" + "OS-EXIT" + "OS-COLD-INIT-OR-REINIT" "OS-DEINIT" + "OS-CONTEXT-T" "OUTPUT-RAW-BYTES" + "READ-CYCLE-COUNTER" "ELAPSED-CYCLES" + "READ-N-BYTES" + "REMOVE-FD-HANDLER" + "REOPEN-SHARED-OBJECTS" + "SAP+" "SAP-" + "SAP-FOREIGN-SYMBOL" + "SAP-INT" + "SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-WORD" + "SAP-REF-8" + "SAP-REF-DOUBLE" "SAP-REF-LISPOBJ" "SAP-REF-LONG" + "SAP-REF-SAP" "SAP-REF-SINGLE" + "SAP<" "SAP<=" "SAP=" "SAP>" "SAP>=" + "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS" + "SIGNAL-DEADLINE" + "SERVE-EVENT" + "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32" + "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-WORD" "SIGNED-SAP-REF-8" + "STRUCTURE!OBJECT" + "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" + "SYSTEM-CONDITION" "SYSTEM-CONDITION-ADDRESS" + "SYSTEM-CONDITION-CONTEXT" + "REINIT-INTERNAL-REAL-TIME" + "SYSTEM-INTERNAL-RUN-TIME" + "UPDATE-LINKAGE-TABLE" "VECTOR-SAP" + "WAIT-UNTIL-FD-USABLE" + "WITH-CODE-PAGES-PINNED" + "WITH-DEADLINE" + "WITH-FD-HANDLER" + "WITH-INTERRUPTS" "WITH-LOCAL-INTERRUPTS" + "WITH-PINNED-OBJECTS" "WITHOUT-GCING" + "WITHOUT-INTERRUPTS" + "WITH-INTERRUPT-BINDINGS")) + + #s(sb-cold:package-data + :name "SB-UNICODE" + :doc "public: algorithms for Unicode data" + :use ("CL" "SB-INT") + :export ("GENERAL-CATEGORY" + "BIDI-CLASS" + "COMBINING-CLASS" + "DECIMAL-VALUE" + "DIGIT-VALUE" + "NUMERIC-VALUE" + "MIRRORED-P" + "BIDI-MIRRORING-GLYPH" + "AGE" + "HANGUL-SYLLABLE-TYPE" + "EAST-ASIAN-WIDTH" + "SCRIPT" + "CHAR-BLOCK" + "UNICODE-1-NAME" + "LINE-BREAK-CLASS" + "PROPLIST-P" + "UPPERCASE-P" + "LOWERCASE-P" + "CASED-P" + "CASE-IGNORABLE-P" + "ALPHABETIC-P" + "IDEOGRAPHIC-P" + "MATH-P" + "WHITESPACE-P" + "HEX-DIGIT-P" + "SOFT-DOTTED-P" + "DEFAULT-IGNORABLE-P" + "NORMALIZE-STRING" + "NORMALIZED-P" + "UPPERCASE" + "LOWERCASE" + "TITLECASE" + "CASEFOLD" + "GRAPHEME-BREAK-CLASS" + "WORD-BREAK-CLASS" + "SENTENCE-BREAK-CLASS" + "GRAPHEMES" + "WORDS" + "SENTENCES" + "LINES" + "UNICODE=" + "UNICODE-EQUAL" + "UNICODE<" + "UNICODE<=" + "UNICODE>" + "UNICODE>=" + "CONFUSABLE-P")) + + #s(sb-cold:package-data + :name "SB-UNIX" + :doc + "private: a wrapper layer for SBCL itself to use when talking +with an underlying Unix-y operating system. +This was a public package in CMU CL, but that was different. +CMU CL's UNIX package tried to provide a comprehensive, +stable Unix interface suitable for the end user. +This package only tries to implement what happens to be +needed by the current implementation of SBCL, and makes +no guarantees of interface stability." + :use ("CL" "SB-ALIEN" "SB-EXT" "SB-INT" "SB-SYS") + :reexport ("OFF-T" + "SIZE-T") + :export ( ;; wrappers around Unix stuff to give just what Lisp needs + "NANOSLEEP" + "UID-USERNAME" + "UID-HOMEDIR" + "USER-HOMEDIR" + "SB-MKSTEMP" + "UNIX-OFFSET" + "FD-TYPE" + + ;; Most of this is random detritus worthy of deletion, + ;; and the ordering is not alphabetical or anything sane. + + ;; stuff with a one-to-one mapping to Unix constructs + "DEV-T" + "F_OK" "GID-T" + "INO-T" "UNIX-ACCESS" "UNIX-SETITIMER" "UNIX-GETITIMER" + "L_INCR" "L_SET" "L_XTND" "O_APPEND" "O_CREAT" "O_NOCTTY" "O_EXCL" + "O_RDONLY" "O_RDWR" "O_TRUNC" "O_WRONLY" "POSIX-GETCWD" + "POSIX-GETCWD/" + "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS" + "RU-MAJFLT" "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND" + "RU-NIVCSW" "RU-NSIGNALS" "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK" + "RU-STIME" "RU-UTIME" "RUSAGE_CHILDREN" "RUSAGE_SELF" + "R_OK" "S-IFDIR" "S-IFLNK" "S-IFMT" + "S-IFREG" + "ST-ATIME" "ST-BLKSIZE" "ST-BLOCKS" + "ST-CTIME" "ST-DEV" "ST-GID" "ST-MODE" "ST-MTIME" "ST-NLINK" + "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "TIME-T" + "TIMEVAL" "TIMEZONE" + "TIOCGPGRP" + "TV-SEC" "TV-USEC" + "TZ-DSTTIME" "TZ-MINUTESWEST" "UID-T" "UNIX-CLOSE" + "UNIX-CLOSEDIR" "UNIX-DIRENT-NAME" "UNIX-DUP" + "UNIX-FILE-MODE" "UNIX-FSTAT" + "UNIX-GETHOSTNAME" "UNIX-GETPID" "UNIX-GETRUSAGE" + "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID" + "UNIX-EXIT" + "UNIX-IOCTL" + "UNIX-ISATTY" "UNIX-LSEEK" "UNIX-LSTAT" "UNIX-MKDIR" + "UNIX-OPEN" "UNIX-OPENDIR" "UNIX-PATHNAME" "UNIX-PID" + "UNIX-PIPE" "UNIX-POLL" "UNIX-SIMPLE-POLL" + "UNIX-READ" "UNIX-READDIR" "UNIX-READLINK" "UNIX-REALPATH" + "UNIX-RENAME" "UNIX-SELECT" "UNIX-STAT" "UNIX-UID" + "UNIX-UNLINK" "UNIX-WRITE" + "WCONTINUED" "WNOHANG" "WUNTRACED" + "W_OK" "X_OK" + "SC-NPROCESSORS-ONLN" + "VOID-SYSCALL" + "CLOCK-THREAD-CPUTIME-ID" + "CLOCK-PROCESS-CPUTIME-ID" + + ;; signals + "SIGALRM" "SIGBUS" "SIGCHLD" "SIGCONT" "SIGEMT" "SIGFPE" + "SIGHUP" "SIGILL" "SIGINT" "SIGIO" "SIGKILL" + "SIGPIPE" "SIGPROF" "SIGQUIT" "SIGSEGV" "SIGSTOP" "SIGSYS" + "SIGTERM" "SIGTRAP" "SIGTSTP" "SIGTTIN" "SIGTTOU" "SIGURG" + "SIGUSR1" "SIGUSR2" "SIGVTALRM" "SIGWINCH" + "SIGXCPU" "SIGXFSZ" + + ;; errors + "EAGAIN" "EBADF" "EEXIST" "EINTR" "EIO" "ELOOP" "ENOENT" + "EPIPE" "ESPIPE" "EWOULDBLOCK" + + "POLLFD" "POLLIN" "POLLOUT" "POLLHUP" "POLLNVAL" "POLLERR" + "FD" "EVENTS" "REVENTS" + "FD-ISSET" "FD-SET" "UNIX-FAST-SELECT" + "PTHREAD-KILL" "RAISE" "UNIX-KILL" "UNIX-KILLPG" + "FD-ZERO" "FD-CLR" + "FD-SETSIZE")) + + #s(sb-cold:package-data + :name "SB-VM" + :doc + "internal: the default place to hide information about the hardware and data +structure representations" + :use ("CL" "SB-ALIEN" "SB-ALIEN-INTERNALS" "SB-ASSEM" "SB-C" + "SB-EXT" "SB-FASL" "SB-INT" "SB-KERNEL" "SB-SYS" "SB-UNIX") + :import-from (("SB-C" "VOP-ARGS" "VOP-RESULTS")) + :reexport ("WORD") + :export ("*PRIMITIVE-OBJECTS*" + "+HIGHEST-NORMAL-GENERATION+" + "+PSEUDO-STATIC-GENERATION+" + "+ARRAY-FILL-POINTER-P+" + "+VECTOR-SHAREABLE+" + "+VECTOR-SHAREABLE-NONSTD+" + "%COMPILER-BARRIER" "%DATA-DEPENDENCY-BARRIER" + "%MEMORY-BARRIER" "%READ-BARRIER" "%WRITE-BARRIER" + "AFTER-BREAKPOINT-TRAP" + #+(and gencgc sparc) "ALLOCATION-TRAP" + "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET" + "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT" + "ARRAY-DISPLACED-FROM-SLOT" + "ARRAY-ELEMENTS-SLOT" + "ARRAY-FILL-POINTER-SLOT" + "ARRAY-RANK-POSITION" "ARRAY-FLAGS-POSITION" + "ARRAY-FLAGS-DATA-POSITION" + "CHARACTER-REG-SC-NUMBER" + "CHARACTER-STACK-SC-NUMBER" "CHARACTER-WIDETAG" + "BIGNUM-DIGITS-OFFSET" "BIGNUM-WIDETAG" "BINDING-SIZE" + "BINDING-SYMBOL-SLOT" "BINDING-VALUE-SLOT" "BREAKPOINT-TRAP" + "N-BYTE-BITS" + "CATCH-BLOCK-CODE-SLOT" + "CATCH-BLOCK-CFP-SLOT" "CATCH-BLOCK-UWP-SLOT" + "CATCH-BLOCK-ENTRY-PC-SLOT" "CATCH-BLOCK-PREVIOUS-CATCH-SLOT" + "CATCH-BLOCK-SC-NUMBER" "CATCH-BLOCK-SIZE" + "CATCH-BLOCK-TAG-SLOT" "CERROR-TRAP" + "CLOSURE-FUN-SLOT" + "CLOSURE-WIDETAG" + "CLOSURE-INFO-OFFSET" + "CODE-BOXED-SIZE-SLOT" + "CODE-CONSTANTS-OFFSET" "CODE-SLOTS-PER-SIMPLE-FUN" + "CODE-DEBUG-INFO-SLOT" + "CODE-HEADER-SIZE-SHIFT" + "CODE-HEADER-WIDETAG" "COMPLEX-ARRAY-WIDETAG" + "COMPLEX-BIT-VECTOR-WIDETAG" "COMPLEX-DOUBLE-FLOAT-FILLER-SLOT" + "COMPLEX-DOUBLE-FLOAT-IMAG-SLOT" "COMPLEX-DOUBLE-FLOAT-REAL-SLOT" + "COMPLEX-DOUBLE-FLOAT-SIZE" "COMPLEX-DOUBLE-FLOAT-WIDETAG" + "COMPLEX-DOUBLE-REG-SC-NUMBER" "COMPLEX-DOUBLE-STACK-SC-NUMBER" + "COMPLEX-IMAG-SLOT" "COMPLEX-REAL-SLOT" + #+long-float("COMPLEX-LONG-FLOAT-IMAG-SLOT" + "COMPLEX-LONG-FLOAT-REAL-SLOT" + "COMPLEX-LONG-FLOAT-SIZE" + "COMPLEX-LONG-FLOAT-WIDETAG" + "COMPLEX-LONG-REG-SC-NUMBER" + "COMPLEX-LONG-STACK-SC-NUMBER") + #+sb-simd-pack("SIMD-PACK-TAG-SLOT" + "SIMD-PACK-HI-VALUE-SLOT" + "SIMD-PACK-LO-VALUE-SLOT" + "SIMD-PACK-SIZE" + "SIMD-PACK-WIDETAG") + #+sb-simd-pack-256("SIMD-PACK-256-TAG-SLOT" + "SIMD-PACK-256-P0-SLOT" + "SIMD-PACK-256-P1-SLOT" + "SIMD-PACK-256-P2-SLOT" + "SIMD-PACK-256-P3-SLOT" + "SIMD-PACK-256-SIZE" + "SIMD-PACK-256-WIDETAG") + #-64-bit + ("COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT") + #+64-bit + "COMPLEX-SINGLE-FLOAT-DATA-SLOT" + "COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-WIDETAG" + "COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER" + "COMPLEX-SIZE" "COMPLEX-BASE-STRING-WIDETAG" + #+sb-unicode "COMPLEX-CHARACTER-STRING-WIDETAG" + "COMPLEX-WIDETAG" + "COMPLEX-VECTOR-WIDETAG" "CONS-CAR-SLOT" "CONS-CDR-SLOT" + "CONS-SIZE" "CONSTANT-SC-NUMBER" + "CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER" + "CONTEXT-PC" "CONTEXT-REGISTER" "BOXED-CONTEXT-REGISTER" + "CONTROL-STACK-SC-NUMBER" + #+sb-safepoint "CSP-SAFEPOINT-TRAP" + "*CURRENT-CATCH-BLOCK*" + "CURRENT-FLOAT-TRAP" + "DESCRIPTOR-REG-SC-NUMBER" + "DO-REFERENCED-OBJECT" + "DOUBLE-FLOAT-BIAS" + "DOUBLE-FLOAT-DIGITS" "DOUBLE-FLOAT-EXPONENT-BYTE" + "DOUBLE-FLOAT-HIDDEN-BIT" + "DOUBLE-FLOAT-NORMAL-EXPONENT-MAX" + "DOUBLE-FLOAT-NORMAL-EXPONENT-MIN" "DOUBLE-FLOAT-SIGNIFICAND-BYTE" + "DOUBLE-FLOAT-SIZE" + "DOUBLE-FLOAT-WIDETAG" "DOUBLE-FLOAT-VALUE-SLOT" + "DOUBLE-REG-SC-NUMBER" + "DOUBLE-STACK-SC-NUMBER" + "DSD-INDEX-SHIFT" + "DSD-RAW-TYPE-MASK" + "EMIT-LONG-NOP" "ERROR-TRAP" "EVEN-FIXNUM-LOWTAG" + "FDEFN-FUN-SLOT" "FDEFN-NAME-SLOT" "FDEFN-RAW-ADDR-SLOT" + "FDEFN-SIZE" "FDEFN-WIDETAG" + "FILLER-WIDETAG" + "FIXNUMIZE" + "FIXNUM-TAG-MASK" + "FIXUP-CODE-OBJECT" "FLOAT-DENORMAL-TRAP-BIT" + "FLOAT-DIVIDE-BY-ZERO-TRAP-BIT" + "FLOAT-INVALID-TRAP-BIT" + "FLOAT-OVERFLOW-TRAP-BIT" "FLOAT-SIGN-SHIFT" + "FLOAT-UNDERFLOW-TRAP-BIT" "FLOATING-POINT-MODES" + "FLOAT-STICKY-BITS" + "FLOAT-TRAPS-BYTE" + "FP-CONSTANT-SC-NUMBER" + "FP-DOUBLE-ZERO-SC-NUMBER" "FP-SINGLE-ZERO-SC-NUMBER" + "FUNCALLABLE-INSTANCE-TRAMPOLINE-SLOT" + "FUNCALLABLE-INSTANCE-WIDETAG" + "FUNCALLABLE-INSTANCE-INFO-OFFSET" + "SIMPLE-FUN-ARGLIST-SLOT" "SIMPLE-FUN-INSTS-OFFSET" + "FUN-END-BREAKPOINT-TRAP" + "SIMPLE-FUN-WIDETAG" + "SIMPLE-FUN-NAME-SLOT" + "SIMPLE-FUN-ENTRY-SAP" + "FUN-POINTER-LOWTAG" + "FUNCTION-LAYOUT" + "SIMPLE-FUN-INFO-SLOT" + "SIMPLE-FUN-SELF-SLOT" + "SIMPLE-FUN-SOURCE-SLOT" + "GENCGC-CARD-BYTES" + "GENCGC-ALLOC-GRANULARITY" + "GENCGC-RELEASE-GRANULARITY" + #+(or arm64 ppc ppc64 sparc riscv) "PSEUDO-ATOMIC-INTERRUPTED-FLAG" + #+(or arm64 ppc ppc64 sparc riscv) "PSEUDO-ATOMIC-FLAG" + #+sb-safepoint "GLOBAL-SAFEPOINT-TRAP" + "HALT-TRAP" "IGNORE-ME-SC-NUMBER" + "IMMEDIATE-SC-NUMBER" + ("CANONICALIZE-INLINE-CONSTANT" + "INLINE-CONSTANT-VALUE" + "SORT-INLINE-CONSTANTS" + "EMIT-INLINE-CONSTANT") + "HEXDUMP" + "INSTANCE-DATA-START" + "INSTANCE-WIDETAG" "INSTANCE-POINTER-LOWTAG" + "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE" + "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGS" + "IS-LISP-POINTER" + #+gencgc "LARGE-OBJECT-SIZE" + "LAYOUT" + "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-LOWTAG" + ;; FIXME: Possibly these other parameters (see + ;; compiler/{x86,sparc}/parms.lisp) should be defined + ;; conditionally on #+LONG-FLOAT) + "LONG-FLOAT-BIAS" "LONG-FLOAT-DIGITS" "LONG-FLOAT-EXPONENT-BYTE" + "LONG-FLOAT-HIDDEN-BIT" "LONG-FLOAT-NORMAL-EXPONENT-MAX" + "LONG-FLOAT-NORMAL-EXPONENT-MIN" "LONG-FLOAT-SIGNIFICAND-BYTE" + #+long-float "LONG-FLOAT-SIZE" + "LONG-FLOAT-TRAPPING-NAN-BIT" + #+long-float("LONG-FLOAT-WIDETAG" + "LONG-FLOAT-VALUE-SLOT" + "LONG-REG-SC-NUMBER" + "LONG-STACK-SC-NUMBER") + "LOWTAG-LIMIT" "LOWTAG-MASK" + "LRA-SAVE-OFFSET" + "MAP-ALLOCATED-OBJECTS" + "MAP-CODE-OBJECTS" + "MAX-INTERRUPTS" + #+c-stack-is-control-stack "MEMORY-FAULT-EMULATION-TRAP" + "UNINITIALIZED-LOAD-TRAP" + "METASPACE-SLAB-SIZE" + "MEMORY-USAGE" + "N-LOWTAG-BITS" + "N-FIXNUM-TAG-BITS" + "N-FIXNUM-BITS" + "N-POSITIVE-FIXNUM-BITS" + "NIL-VALUE" + "NFP-SAVE-OFFSET" + "NON-DESCRIPTOR-REG-SC-NUMBER" + "NULL-SC-NUMBER" + "OCFP-SAVE-OFFSET" + "ODD-FIXNUM-LOWTAG" + "OTHER-IMMEDIATE-0-LOWTAG" + "OTHER-IMMEDIATE-1-LOWTAG" + "OTHER-IMMEDIATE-2-LOWTAG" + "OTHER-IMMEDIATE-3-LOWTAG" + "OTHER-POINTER-LOWTAG" + "PAD0-LOWTAG" "PAD1-LOWTAG" "PAD2-LOWTAG" + "PAD3-LOWTAG" "PAD4-LOWTAG" "PAD5-LOWTAG" + "PAD-DATA-BLOCK" "PENDING-INTERRUPT-TRAP" + "PRIMITIVE-OBJECT" "PRIMITIVE-OBJECT-WIDETAG" + "PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME" + "PRIMITIVE-OBJECT-P" + "PRIMITIVE-OBJECT-LENGTH" "PRIMITIVE-OBJECT-SLOTS" + "PRIMITIVE-OBJECT-VARIABLE-LENGTH-P" + "PRINT-ALLOCATED-OBJECTS" + "RATIO-DENOMINATOR-SLOT" "RATIO-NUMERATOR-SLOT" + "RATIO-SIZE" "RATIO-WIDETAG" + "*READ-ONLY-SPACE-FREE-POINTER*" + "RETURN-PC-WIDETAG" + "RETURN-PC-RETURN-POINT-OFFSET" "RETURN-PC-SAVE-OFFSET" + "SAETP-CTYPE" "SAETP-INITIAL-ELEMENT-DEFAULT" + "SAETP-N-BITS" "SAETP-TYPECODE" "SAETP-PRIMITIVE-TYPE-NAME" + "SAETP-N-PAD-ELEMENTS" "SAETP-N-BITS-SHIFT" + "SAETP-SPECIFIER" + "SAETP-COMPLEX-TYPECODE" + "SAETP-FIXNUM-P" + "VALID-BIT-BASH-SAETP-P" + "*SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*" + "SANCTIFY-FOR-EXECUTION" + "SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE" + "SAP-STACK-SC-NUMBER" "SAP-WIDETAG" + "SC-NUMBER-LIMIT" "SC-NUMBER-BITS" ; SC-NUMBER in package "SB-C" + "SC-OFFSET-LIMIT" "SC-OFFSET-BITS" "SC-OFFSET" + "FINITE-SC-OFFSET-LIMIT" "FINITE-SC-OFFSET-BITS" "FINITE-SC-OFFSET" + "FINITE-SC-OFFSET-MAP" + "SHORT-HEADER-MAX-WORDS" + "SIGFPE-HANDLER" "SIGNED-REG-SC-NUMBER" "SIGNED-STACK-SC-NUMBER" + "SIGNED-WORD" + "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-WIDETAG" + #+long-float "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-WIDETAG" + "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-WIDETAG" + "SIMPLE-ARRAY-DOUBLE-FLOAT-WIDETAG" + #+long-float "SIMPLE-ARRAY-LONG-FLOAT-WIDETAG" + "SIMPLE-ARRAY-NIL-WIDETAG" + "SIMPLE-ARRAY-SINGLE-FLOAT-WIDETAG" + "SIMPLE-ARRAY-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-15-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-16-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-2-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-FIXNUM-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-31-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-32-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-63-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-64-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-4-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-7-WIDETAG" + "SIMPLE-ARRAY-UNSIGNED-BYTE-8-WIDETAG" + "SIMPLE-ARRAY-SIGNED-BYTE-16-WIDETAG" + "SIMPLE-ARRAY-FIXNUM-WIDETAG" + "SIMPLE-ARRAY-SIGNED-BYTE-32-WIDETAG" + "SIMPLE-ARRAY-SIGNED-BYTE-64-WIDETAG" + "SIMPLE-ARRAY-SIGNED-BYTE-8-WIDETAG" + "SIMPLE-BIT-VECTOR-WIDETAG" + "SIMPLE-BASE-STRING-WIDETAG" + #+sb-unicode "SIMPLE-CHARACTER-STRING-WIDETAG" + "SIMPLE-VECTOR-WIDETAG" "SINGLE-FLOAT-BIAS" + "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE" + "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX" + "SINGLE-FLOAT-NORMAL-EXPONENT-MIN" "SINGLE-FLOAT-SIGNIFICAND-BYTE" + "SINGLE-FLOAT-SIZE" + "SINGLE-FLOAT-WIDETAG" + #-64-bit "SINGLE-FLOAT-VALUE-SLOT" + "SINGLE-REG-SC-NUMBER" "SINGLE-STACK-SC-NUMBER" + "SINGLE-STEP-AROUND-TRAP" + "SINGLE-STEP-BEFORE-TRAP" + "SINGLE-STEP-BREAKPOINT-TRAP" + "INVALID-ARG-COUNT-TRAP" + "SINGLE-VALUE-RETURN-BYTE-OFFSET" + "SLOT-NAME" "SLOT-OFFSET" + "SLOT-SPECIAL" + "+STATIC-FDEFNS+" "STATIC-FUN-OFFSET" + "%SPACE-BOUNDS" "SPACE-BYTES" + "STABLE-HASH-REQUIRED-FLAG" + "HASH-SLOT-PRESENT-FLAG" + "STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P" + "+STATIC-SYMBOLS+" + "SYMBOL-HASH-SLOT" "SYMBOL-WIDETAG" "SYMBOL-NAME-SLOT" + "SYMBOL-PACKAGE-SLOT" "SYMBOL-INFO-SLOT" + "SYMBOL-SIZE" "SYMBOL-VALUE-SLOT" "SYMBOL-TLS-INDEX-SLOT" + "EXTENDED-SYMBOL-SIZE" + "*BINDING-STACK-START*" + "*CONTROL-STACK-START*" "*CONTROL-STACK-END*" + "CONTROL-STACK-POINTER-VALID-P" + "DYNAMIC-SPACE-START" "DYNAMIC-SPACE-END" + #+gencgc("MAX-DYNAMIC-SPACE-END" + "PAGE-TABLE" + "FIND-PAGE-INDEX" + "NEXT-FREE-PAGE") + #-gencgc("DYNAMIC-0-SPACE-START" + "DYNAMIC-0-SPACE-END") + #+immobile-space("IMMOBILE-CARD-BYTES" + "FIXEDOBJ-SPACE-START" "FIXEDOBJ-SPACE-SIZE" + "VARYOBJ-SPACE-START" "VARYOBJ-SPACE-SIZE" + "*FIXEDOBJ-SPACE-FREE-POINTER*" + "*VARYOBJ-SPACE-FREE-POINTER*") + "READ-ONLY-SPACE-START" "READ-ONLY-SPACE-END" + "STATIC-SPACE-START" "STATIC-SPACE-END" "*STATIC-SPACE-FREE-POINTER*" + "STATIC-CODE-SPACE-START" "STATIC-CODE-SPACE-END" "*STATIC-CODE-SPACE-FREE-POINTER*" + ("LINKAGE-TABLE-SPACE-START" + "LINKAGE-TABLE-SPACE-END" + "LINKAGE-TABLE-ENTRY-SIZE") + #+sb-safepoint "GC-SAFEPOINT-PAGE-ADDR" + #+sb-safepoint "GC-SAFEPOINT-TRAP-OFFSET" + "THREAD-STATE-WORD-SLOT" + "THREAD-SPROF-DATA-SLOT" + "TLS-SIZE" "N-WIDETAG-BITS" "WIDETAG-MASK" + "INSTANCE-LENGTH-SHIFT" + "INSTANCE-LENGTH-MASK" + "UNBOUND-MARKER-WIDETAG" + "UNDEFINED-FUNCTION-TRAP" + "NO-TLS-VALUE-MARKER-WIDETAG" + "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER" + "UNWIND-BLOCK-CODE-SLOT" "UNWIND-BLOCK-CFP-SLOT" + "UNWIND-BLOCK-UWP-SLOT" "UNWIND-BLOCK-ENTRY-PC-SLOT" + "UNWIND-BLOCK-SIZE" "VALUE-CELL-WIDETAG" "VALUE-CELL-SIZE" + "VALUE-CELL-VALUE-SLOT" "VECTOR-DATA-OFFSET" "VECTOR-LENGTH-SLOT" + "VECTOR-WEAK-FLAG" + "VECTOR-WEAK-VISITED-FLAG" + "VECTOR-HASHING-FLAG" + "VECTOR-ADDR-HASHING-FLAG" + #+(and win32 x86-64) "WIN64-SEH-DATA-ADDR" + "WEAK-POINTER-NEXT-SLOT" + "WEAK-POINTER-SIZE" "WEAK-POINTER-WIDETAG" + "WEAK-POINTER-VALUE-SLOT" + "N-WORD-BITS" "N-WORD-BYTES" "N-MACHINE-WORD-BITS" "N-MACHINE-WORD-BYTES" + "WORD-REG-SC-NUMBER" "WORD-SHIFT" + #+win32 "CONTEXT-RESTORE-TRAP" + "ZERO-SC-NUMBER")) + + #s(sb-cold:package-data + :name "SB-RBTREE" + :doc "internal: red/black tree" + :use ("CL" "SB-INT" "SB-EXT") + :shadow ("DELETE") + :export ("INSERT" "DELETE" "FIND=" "FIND<=")) + + #s(sb-cold:package-data + :name "SB-LOCKLESS" + :doc "internal: lockfree lists" + :use ("CL" "SB-INT" "SB-EXT" "SB-SYS" "SB-KERNEL") + :shadow ("ENDP")) + + #s(sb-cold:package-data + :name "SB-WALKER" + :doc "internal: a code walker used by PCL" + :use ("CL" "SB-INT" "SB-EXT")) + + #+sb-eval + #s(sb-cold:package-data + :name "SB-EVAL" + :doc "internal: the evaluator implementation used to execute code without compiling it." + :use ("CL" "SB-KERNEL" "SB-EXT" "SB-INT") + :reexport ("*EVAL-CALLS*") + :export ("INTERPRETED-FUNCTION-NAME" + "INTERPRETED-FUNCTION-DEBUG-NAME" + "INTERPRETED-FUNCTION-LAMBDA-LIST" + "INTERPRETED-FUNCTION-DEBUG-LAMBDA-LIST" + "INTERPRETED-FUNCTION-DECLARATIONS" + "INTERPRETED-FUNCTION-DOCUMENTATION" + "INTERPRETED-FUNCTION-BODY" + "INTERPRETED-FUNCTION-SOURCE-LOCATION" + "EVAL-IN-ENVIRONMENT" + "MAKE-NULL-ENVIRONMENT" + "EVAL-IN-NATIVE-ENVIRONMENT" + "*EVAL-LEVEL*")) + + #+sb-fasteval + #s(sb-cold:package-data + :name "SB-INTERPRETER" + :doc "internal: a new EVAL implementation with semantic preprocessing." + :use ("CL" "SB-KERNEL" "SB-EXT" "SB-INT") + :export ("BASIC-ENV" + "ENV-POLICY" + "EVAL-IN-ENVIRONMENT" + "FIND-LEXICAL-FUN" + "FIND-LEXICAL-VAR" + "FUN-LAMBDA-EXPRESSION" + "FUN-LAMBDA-LIST" + "FUN-PROTO-FN" + "FUN-SOURCE-LOCATION" + "%FUN-FTYPE" + "LEXENV-FROM-ENV" + "LIST-LOCALS" + "PROTO-FN-DOCSTRING" + "PROTO-FN-NAME" + "PROTO-FN-PRETTY-ARGLIST" + "TYPE-CHECK") + :import-from (("SB-C" + "PARSE-EVAL-WHEN-SITUATIONS" + "MAKE-GLOBAL-VAR" "MAKE-LAMBDA-VAR" + "*LEXENV*") + ("SB-VM" "SYMBOL-EXTRA-SLOT-P" "SYMBOL-EXTRA") + ("SB-ALIEN" "%HEAP-ALIEN" "ALIEN-VALUE") + ("SB-KERNEL" "%%TYPEP"))) + + #+win32 + #s(sb-cold:package-data + :name "SB-WIN32" + :doc "private: a wrapper layer for Win32 functions needed by +SBCL itself" + :use ("CL" "SB-ALIEN" "SB-EXT" "SB-INT" "SB-SYS") + :export ("BOOL" + "CLOSE-HANDLE" + "CREATE-FILE" + "CREATE-FILE-MAPPING" + "CRYPT-GEN-RANDOM" + "DWORD" + "EXCEPTION" + "EXCEPTION-RECORD" + "EXCEPTION-CONTEXT" + "EXCEPTION-CODE" + "FILE-CREATE-ALWAYS" + "FILE-CREATE-NEW" + "FILE-OPEN-ALWAYS" + "FILE-OPEN-EXISTING" + "FILE-TRUNCATE-EXISTING" + "FLUSH-CONSOLE-INPUT-BUFFER" + "FLUSH-VIEW-OF-FILE" + "FORMAT-SYSTEM-MESSAGE" + "GET-FILE-ATTRIBUTES" + "GET-FILE-SIZE-EX" + "GET-FILE-TYPE" + "GET-LAST-ERROR" + "GET-OSFHANDLE" + "GET-VERSION-EX" + "HANDLE" + "HANDLE-CLEAR-INPUT" + "HANDLE-LISTEN" + "INT-PTR" + "INVALID-HANDLE" + "LSEEKI64" + "MAP-VIEW-OF-FILE" + "MILLISLEEP" + "PEEK-CONSOLE-INPUT" + "PEEK-NAMED-PIPE" + "READ-FILE" + "UNIXLIKE-CLOSE" + "UNIXLIKE-OPEN" + "UNMAP-VIEW-OF-FILE" + "WAIT-OBJECT-OR-SIGNAL" + "WRITE-FILE" + "WITH-PROCESS-TIMES"))) + +;;; The following symbols may be referenced without seeing a definition +;;; during make-host-2. No warning will result. +;;; This list is read after packages are created from the data above. +((;; CL, EXT, KERNEL + allocate-instance + compute-applicable-methods + slot-makunbound + make-load-form-saving-slots + sb-vm:map-allocated-objects + sb-ext:primitive-object-size + sb-vm::remove-static-links) + ;; CLOS implementation + (sb-mop:class-finalized-p + sb-mop:class-prototype + sb-mop:class-slots + sb-pcl::eql-specializer-to-ctype + sb-mop:finalize-inheritance + sb-mop:generic-function-name + (setf sb-mop:generic-function-name) + sb-mop:slot-definition-allocation + sb-mop:slot-definition-name + sb-pcl::method-p + sb-mop:method-function + sb-pcl::%force-cache-flushes + sb-pcl::check-wrapper-validity + sb-pcl::class-has-a-forward-referenced-superclass-p + sb-pcl::class-wrapper + sb-pcl::compute-gf-ftype + sb-pcl::definition-source + sb-pcl::ensure-accessor + sb-pcl:ensure-class-finalized) + ;; CLOS-based packages + (sb-gray:stream-clear-input + sb-gray:stream-clear-output + sb-gray:stream-file-position + sb-gray:stream-finish-output + sb-gray:stream-force-output + sb-gray:stream-fresh-line + sb-gray:stream-line-column + sb-gray:stream-line-length + sb-gray:stream-listen + sb-gray:stream-peek-char + sb-gray:stream-read-byte + sb-gray:stream-read-char + sb-gray:stream-read-char-no-hang + sb-gray:stream-read-line + sb-gray:stream-read-sequence + sb-gray:stream-terpri + sb-gray:stream-unread-char + sb-gray:stream-write-byte + sb-gray:stream-write-char + sb-gray:stream-write-sequence + sb-gray:stream-write-string + sb-sequence:concatenate + sb-sequence:copy-seq + sb-sequence:count + sb-sequence:count-if + sb-sequence:count-if-not + sb-sequence:delete + sb-sequence:delete-duplicates + sb-sequence:delete-if + sb-sequence:delete-if-not + (setf sb-sequence:elt) + sb-sequence:elt + sb-sequence:emptyp + sb-sequence:fill + sb-sequence:find + sb-sequence:find-if + sb-sequence:find-if-not + (setf sb-sequence:iterator-element) + sb-sequence:iterator-endp + sb-sequence:iterator-step + sb-sequence:length + sb-sequence:make-sequence-iterator + sb-sequence:make-sequence-like + sb-sequence:map + sb-sequence:merge + sb-sequence:mismatch + sb-sequence:nreverse + sb-sequence:nsubstitute + sb-sequence:nsubstitute-if + sb-sequence:nsubstitute-if-not + sb-sequence:position + sb-sequence:position-if + sb-sequence:position-if-not + sb-sequence:reduce + sb-sequence:remove + sb-sequence:remove-duplicates + sb-sequence:remove-if + sb-sequence:remove-if-not + sb-sequence:replace + sb-sequence:reverse + sb-sequence:search + sb-sequence:sort + sb-sequence:stable-sort + sb-sequence:subseq + sb-sequence:substitute + sb-sequence:substitute-if + sb-sequence:substitute-if-not) + ;; Fast interpreter + #+sb-fasteval + (sb-interpreter:%fun-ftype + sb-interpreter:env-policy + sb-interpreter:eval-in-environment + sb-interpreter:find-lexical-fun + sb-interpreter:find-lexical-var + sb-interpreter::flush-everything + sb-interpreter::fun-lexically-notinline-p + sb-interpreter:lexenv-from-env + sb-interpreter::lexically-unlocked-symbol-p + sb-interpreter:list-locals + sb-interpreter::reconstruct-syntactic-closure-env) + ;; Simple-streams symbols in SB-IMPL + (sb-impl::s-%charpos + sb-impl::s-%clear-output + sb-impl::s-%file-length + sb-impl::s-%file-name + sb-impl::s-%file-position + sb-impl::s-%file-string-length + sb-impl::s-%finish-output + sb-impl::s-%force-output + sb-impl::s-%fresh-line + sb-impl::s-%line-length + sb-impl::s-%peek-char + sb-impl::s-%read-byte + sb-impl::s-%read-char + sb-impl::s-%read-char-no-hang + sb-impl::s-%read-line + sb-impl::s-%stream-external-format + sb-impl::s-%terpri + sb-impl::s-%unread-char + sb-impl::s-%write-byte + sb-impl::s-%write-char + sb-impl::s-%write-line + sb-impl::s-%write-sequence + sb-impl::s-%write-string) + ;; Other + (sb-debug::find-interrupted-name-and-frame + sb-impl::encapsulate-generic-function + sb-impl::encapsulated-generic-function-p + sb-impl::get-processes-status-changes + sb-impl::step-form + sb-impl::step-values + sb-impl::stringify-package-designator + sb-impl::stringify-string-designator + sb-impl::stringify-string-designators + sb-impl::unencapsulate-generic-function) + ;; The following functions are in fact defined during make-host-2 + ;; but they are non-toplevel so they appear to be undefined. + (sb-int:gensymify* + sb-int:keywordicate + sb-int:package-symbolicate + sb-int:symbolicate + sb-kernel::preinform-compiler-about-accessors + sb-kernel::preinform-compiler-about-slot-functions + sb-impl::bytes-per-utf8-character-aref + sb-impl::bytes-per-utf8-character-sap-ref-8 + sb-impl::user-homedir-namestring + sb-c::apply-core-fixups + sb-c::compiled-debug-info-char-offset + sb-c::compiled-debug-info-tlf-number + sb-c::fopcompilable-p + sb-c::pack-xref-data + sb-c::prepare-for-compile + sb-sys:reinit-internal-real-time)) diff -Nru sbcl-2.1.1/src/cold/set-up-cold-packages.lisp sbcl-2.1.11/src/cold/set-up-cold-packages.lisp --- sbcl-2.1.1/src/cold/set-up-cold-packages.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/set-up-cold-packages.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -272,6 +272,8 @@ ;; The cross-compiler itself shouldn't really need to use the host ;; versions of these in target code except in exceptional cases. + "CHAR-CODE" + "CODE-CHAR" "COMPILE-FILE" "COMPILE-FILE-PATHNAME" "*COMPILE-FILE-PATHNAME*" @@ -285,7 +287,9 @@ "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*" + "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" + "PROCLAIM" "SPECIAL-OPERATOR-P" "SUBTYPEP" "UPGRADED-ARRAY-ELEMENT-TYPE" @@ -345,25 +349,17 @@ ;; compilation of the target. ;; (let ((package-name "SB-XC")) - (dolist (name (append (append *undefineds* *dual-personality-math-symbols*))) + (dolist (name (append *undefineds* *dual-personality-math-symbols*)) (export (intern name package-name) package-name)) (dolist (name '("*READ-DEFAULT-FLOAT-FORMAT*" "ARRAY-ELEMENT-TYPE" - "CHAR-CODE" - "CODE-CHAR" "DEFMACRO" "DEFSTRUCT" "DEFTYPE" "GENSYM" "MAKE-ARRAY" - "MAKE-LOAD-FORM" - "PROCLAIM" "SIMPLE-VECTOR" - "TYPE-OF" "TYPEP" - - "DEFCLASS" - "DEFGENERIC" - "DEFMETHOD" + "TYPEP" )) - (export (intern name package-name) package-name))) + (export (intern name package-name) package-name))) (defun count-symbols (pkg) (let ((n 0)) @@ -382,7 +378,7 @@ (import x cl-model-package) (export x cl-model-package))) (reexport (list nil)) - (dolist (string (read-from-file "common-lisp-exports.lisp-expr")) + (dolist (string (read-from-file "^common-lisp-exports.lisp-expr")) (unless (string= string "NIL") ; already done (cond ((member string *undefineds* :test #'string=) (new-external string cl-model-package)) @@ -486,7 +482,7 @@ (export '*undefined-fun-allowlist*) (defvar *undefined-fun-allowlist* (make-hash-table :test 'equal)) (let ((list - (with-open-file (data (prepend-genfile-path "package-data-list.lisp-expr")) + (with-open-file (data (find-bootstrap-file "^package-data-list.lisp-expr")) ;; There's no need to use the precautionary READ-FROM-FILE function ;; with package-data-list because it is not a customization file. (create-target-packages (let ((*readtable* *xc-readtable*)) (read data))) @@ -519,7 +515,7 @@ (defun package-list-for-genesis () (append (let ((*readtable* *xc-readtable*)) - (read-from-file "package-data-list.lisp-expr" nil)) + (read-from-file "^package-data-list.lisp-expr" nil)) (let ((asm-package (backend-asm-package-name))) (list (make-package-data :name asm-package :use (list* "CL" *asm-package-use-list*) @@ -529,7 +525,8 @@ ;;; by the tree-shaker as intended. #+nil (defun show-unused-exports (&aux nonexistent uninteresting) - (dolist (entry (with-open-file (f "package-data-list.lisp-expr") (read f))) + (dolist (entry (with-open-file (find-bootstrap-file "^package-data-list.lisp-expr") + (read f))) (let ((pkg (find-package (package-data-name entry)))) (dolist (string (mapcan (lambda (x) (if (stringp x) (list x) x)) (package-data-export entry))) @@ -538,7 +535,7 @@ (cond ((not s) (push (cons pkg string) nonexistent)) ((and (not (boundp s)) - (not (sb-kernel:symbol-info s)) + (not (sb-kernel:symbol-%info s)) (not (gethash s sb-c::*backend-parsed-vops*))) (push s uninteresting)))))))) (format t "~&Nonexistent:~%") diff -Nru sbcl-2.1.1/src/cold/shared.lisp sbcl-2.1.11/src/cold/shared.lisp --- sbcl-2.1.1/src/cold/shared.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/shared.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -44,6 +44,7 @@ value2))))) (defvar *make-host-parallelism* nil) +(defvar *fail-on-warnings* t) (defun make-host-1-parallelism () (car *make-host-parallelism*)) (defun make-host-2-parallelism () (cdr *make-host-parallelism*)) @@ -163,24 +164,42 @@ (rename-file x path))) (compile 'rename-file-a-la-unix) -(export '(prepend-genfile-path read-from-file *generated-sources-root*)) +(export '(*target-sbcl-version* *generated-sources-root* + stem-source-path find-bootstrap-file read-from-file)) +(defvar *sources-root* "") (defvar *generated-sources-root* "") +(defvar *src-cold-shared-pathname* *load-pathname*) ;;; See remark in COMPILE-STEM about strings vs. The Common Lisp Way -(defun prepend-genfile-path (namestring) - (concatenate 'string - ;; if exact match to "output/", or mismatch at the next character - (if (member (mismatch "output/" namestring) '(nil 7)) - *generated-sources-root* - "") - namestring)) -(compile 'prepend-genfile-path) ; seems in vogue to compile everything in this file +(defun find-bootstrap-file (namestring) + (cond ((char= (char namestring 0) #\^) + ;; If it starts with a "^" then it means "src/cold/..." + (let ((this *src-cold-shared-pathname*) + (name (subseq namestring 1))) + (make-pathname :host (pathname-host this) + :device (pathname-device this) + :directory (pathname-directory this) + :name (pathname-name name) + :type (or (pathname-type name) (pathname-type this))))) + ((find #\/ namestring) + ;; Otherwise if it contains a slash, then it's a source file which is either + ;; in the tree as checked in, or generated by a prior build step. + (concatenate 'string + (if (eql (mismatch "output/" namestring) 7) ; a generated source + *generated-sources-root* + *sources-root*) + namestring)) + (t + ;; Else, it's an optional user-supplied customization file, + ;; or a generated data file in the root directory such as "version.lisp-expr" + namestring))) +(compile 'find-bootstrap-file) ; seems in vogue to compile everything in this file ;;; Return an expression read from the file named NAMESTRING. ;;; For user-supplied inputs, protect against more than one expression -;;; appearing in the file. With trusted inputs we needn't bother. +;;; appearing in the file. For in-tree inputs we needn't bother. (defun read-from-file (namestring &optional (enforce-single-expr t)) - (with-open-file (s (prepend-genfile-path namestring)) + (with-open-file (s (find-bootstrap-file namestring)) (let* ((result (read s)) (eof-result (cons nil nil))) (unless enforce-single-expr @@ -201,7 +220,7 @@ #+sbcl (progn (setq cl:*compile-print* nil) - (load "src/cold/muffler.lisp") + (load (find-bootstrap-file "^muffler")) ;; Let's just say we never care to see these. (declaim (sb-ext:muffle-conditions (satisfies unable-to-optimize-note-p) @@ -211,16 +230,17 @@ ;;;; special read-macros for building the cold system (and even for ;;;; building some of our tools for building the cold system) -(load "src/cold/shebang.lisp") +(load (find-bootstrap-file "^shebang")) -(defvar *shebang-backend-subfeatures* - (let* ((default-subfeatures nil) - (customizer-file-name "customize-backend-subfeatures.lisp") - (customizer (if (probe-file customizer-file-name) - (compile nil - (read-from-file customizer-file-name)) - #'identity))) - (funcall customizer default-subfeatures))) +;;; Subfeatures could be assigned as late as the beginning of make-host-2, +;;; but I don't want to introduce another mechanism for delaying reading +;;; of the customizer just because we can. +;;; But it's not well-advertised; does it really merit a customization file? +(export 'backend-subfeatures) +(defvar backend-subfeatures + (let ((customizer-file-name "customize-backend-subfeatures.lisp")) + (when (probe-file customizer-file-name) + (copy-list (funcall (compile nil (read-from-file customizer-file-name)) nil))))) ;;; When cross-compiling, the *FEATURES* set for the target Lisp is ;;; not in general the same as the *FEATURES* set for the host Lisp. @@ -236,50 +256,52 @@ ;;; The compromise is to examine a variable specifying a path ;;; (and it can't go in SB-COLD because the package is not made soon enough) (setf sb-xc:*features* - (let* ((pathname (let ((var 'cl-user::*sbcl-target-features-file*)) + (let* ((pathname (let ((var 'cl-user::*sbcl-local-target-features-file*)) (if (boundp var) (symbol-value var) "local-target-features.lisp-expr"))) (default-features (funcall (compile nil (read-from-file pathname)) - (read-from-file "base-target-features.lisp-expr"))) + (read-from-file "^base-target-features.lisp-expr"))) (customizer-file-name "customize-target-features.lisp") (customizer (if (probe-file customizer-file-name) (compile nil (read-from-file customizer-file-name)) #'identity)) - (target-feature-list (funcall customizer default-features)) + ;; Bind temporarily so that TARGET-FEATUREP and TARGET-PLATFORM-KEYWORD + ;; can see the tentative list. + (sb-xc:*features* (funcall customizer default-features)) (gc (find-if (lambda (x) (member x '(:cheneygc :gencgc))) - target-feature-list)) - (arch (target-platform-keyword target-feature-list))) + sb-xc:*features*)) + (arch (target-platform-keyword))) ;; Win32 conditionally adds :sb-futex in grovel-features.sh - (when (featurep '(:and :sb-thread (:or :linux :freebsd)) target-feature-list) - (pushnew :sb-futex target-feature-list)) - (when (featurep '(:and :sb-thread (:not :win32)) target-feature-list) - (push :pauseless-threadstart target-feature-list)) - (when (featurep '(:and :sb-thread (:or :darwin :openbsd)) target-feature-list) - (push :os-thread-stack target-feature-list)) - (when (and (member :x86 target-feature-list) - (member :int4-breakpoints target-feature-list)) + (when (target-featurep '(:and :sb-thread (:or :linux :freebsd))) + (pushnew :sb-futex sb-xc:*features*)) + (when (target-featurep '(:and :sb-thread (:not :win32))) + (push :pauseless-threadstart sb-xc:*features*)) + (when (target-featurep '(:and :sb-thread (:or :darwin :openbsd))) + (push :os-thread-stack sb-xc:*features*)) + (when (target-featurep '(:and :x86 :int4-breakpoints)) ;; 0xCE is a perfectly good 32-bit instruction, ;; unlike on x86-64 where it is illegal. It's therefore ;; confusing to allow this feature in a 32-bit build. ;; But it's annoying to have a build script that otherwise works ;; for a native x86/x86-64 build except for needing one change. ;; Just print something and go on with life. - (setq target-feature-list - (remove :int4-breakpoints target-feature-list)) + (setq sb-xc:*features* (remove :int4-breakpoints sb-xc:*features*)) (warn "Removed :INT4-BREAKPOINTS from target features")) - (when (or (member :arm64 target-feature-list) - (member :sse4 *shebang-backend-subfeatures*)) - (push :round-float target-feature-list)) + (when (target-featurep '(:or :arm64 :sse4)) + (push :round-float sb-xc:*features*)) + (when (target-featurep '(:and :arm64 :darwin)) + (push :arm-v8.1 backend-subfeatures)) + ;; Putting arch and gc choice first is visually convenient, versus ;; having to parse a random place in the line to figure out the value ;; of a binary choice {cheney vs gencgc} and architecture. ;; De-duplicate the rest of the symbols because the command line ;; can add redundant --with-mumble options. (list* arch gc (sort (remove-duplicates - (remove arch (remove gc target-feature-list))) + (remove arch (remove gc sb-xc:*features*))) #'string<)))) ;;; Call for effect of signaling an error if no target picked. @@ -300,23 +322,20 @@ ("(and pauseless-threadstart (not sb-thread))" ":PAUSELESS-THREADSTART requires :SB-THREAD") ("(and sb-safepoint (not sb-thread))" ":SB-SAFEPOINT requires :SB-THREAD") - ("(and sb-thruption (not sb-safepoint))" ":SB-THRUPTION requires :SB-SAFEPOINT") - ("(and unix sb-safepoint-strictly)" - ":SB-SAFEPOINT-STRICTLY not supported on this platform") ("(and sb-thread (not (or riscv ppc ppc64 x86 x86-64 arm64)))" ":SB-THREAD not supported on selected architecture") + ("(and (not sb-thread) (or arm64 ppc64))" + "The selected architecture requires :SB-THREAD") ("(and gencgc cheneygc)" ":GENCGC and :CHENEYGC are incompatible") - ("(and cheneygc (not (or arm arm64 mips ppc riscv sparc)))" + ("(and cheneygc (not (or arm mips ppc riscv sparc)))" ":CHENEYGC not supported on selected architecture") ("(and gencgc (not (or sparc ppc ppc64 x86 x86-64 arm arm64 riscv)))" ":GENCGC not supported on selected architecture") ("(not (or gencgc cheneygc))" "One of :GENCGC or :CHENEYGC must be enabled") - ("(and sb-safepoint (not (or arm64 ppc x86 x86-64)))" - ":SB-SAFEPOINT not supported on selected architecture") - ("(and sb-safepoint-strictly (not sb-safepoint))" - ":SB-SAFEPOINT-STRICTLY requires :SB-SAFEPOINT") + ("(and sb-safepoint (not (and (or arm64 x86 x86-64) (or darwin linux win32))))" + ":SB-SAFEPOINT not supported on selected arch/OS") ("(not (or elf mach-o win32))" "No execute object file format feature defined") ("(and cons-profiling (not sb-thread))" ":CONS-PROFILING requires :SB-THREAD") @@ -360,7 +379,7 @@ ;;; All code depending on this is itself dependent on #+SB-SHOW. (defvar *cl-snapshot*) (when (member :sb-show sb-xc:*features*) - (load "src/cold/snapshot.lisp") + (load (find-bootstrap-file "^snapshot")) (setq *cl-snapshot* (take-snapshot "COMMON-LISP"))) ;;;; master list of source files and their properties @@ -396,14 +415,6 @@ ;; :NOT-HOST is also set, since the SBCL assembler doesn't exist ;; while the cross-compiler is being built in the host ANSI Lisp.) :assem - ;; meaning: The #'COMPILE-STEM argument called :IGNORE-FAILURE-P - ;; should be true. (This is a KLUDGE: I'd like to get rid of it. - ;; For now, it exists so that compilation can proceed through the - ;; legacy warnings in src/compiler/x86/array.lisp, which I've - ;; never figured out but which were apparently acceptable in CMU - ;; CL. Eventually, it would be great to just get rid of all - ;; warnings and remove support for this flag. -- WHN 19990323) - :ignore-failure-p ;; meaning: ignore this flag. ;; This works around nonstandard behavior of "#." in certain hosts. ;; When the evaluated form yields 0 values, ECL and CLISP treat it @@ -427,8 +438,8 @@ (,flags (rest ,stem-and-flags))) ,@body)))) -;;; Given a STEM, remap the path component "/target/" to a suitable -;;; target directory. +;;; Given a STEM, remap the path components "/{arch}/" and "/asm-target/" +;;; to suitable directories. (defun stem-remap-target (stem) (flet ((try-replacing (this that) (let ((position (search this stem))) @@ -437,20 +448,20 @@ (subseq stem 0 (1+ position)) (string-downcase that) (subseq stem (+ position (length this) -1))))))) - (or (try-replacing "/target/" (target-platform-keyword)) + (or (try-replacing "/{arch}/" (target-platform-keyword)) (try-replacing "/asm-target/" (backend-assembler-target-name)) stem))) (compile 'stem-remap-target) ;;; Determine the source path for a stem by remapping from the abstract name -;;; if it contains "/target/" and appending a ".lisp" suffix. +;;; if it contains "/{arch}/" and appending a ".lisp" suffix. ;;; Assume that STEM is source-tree-relative unless it starts with "output/" ;;; in which case it could be elsewhere, if you prefer to keep the sources ;;; devoid of compilation artifacts. (The production of out-of-tree artifacts ;;; is not actually implemented in the generic build, however if your build ;;; system does that by itself, then hooray for you) (defun stem-source-path (stem) - (concatenate 'string (prepend-genfile-path (stem-remap-target stem)) ".lisp")) + (concatenate 'string (find-bootstrap-file (stem-remap-target stem)) ".lisp")) (compile 'stem-source-path) ;;; Determine the object path for a stem/flags/mode combination. @@ -490,7 +501,7 @@ ;; to produce warnings as a bug workaround. (let ((cl:*features* (cons feature cl:*features*)) (*readtable* *xc-readtable*)) - (read-from-file "build-order.lisp-expr" nil)))) + (read-from-file "^build-order.lisp-expr" nil)))) (setf *stems-and-flags* (cons build-phase list))) ;; Now check for duplicate stems and bogus flags. (let ((stems (make-hash-table :test 'equal))) @@ -529,42 +540,43 @@ ;;; STEM and FLAGS are as per DO-STEMS-AND-FLAGS. MODE is one of ;;; :HOST-COMPILE and :TARGET-COMPILE. (defun compile-stem (stem flags mode) - - (let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common - ;; Lisp Way, although it works just fine for common UNIX environments. - ;; Should it come to pass that the system is ported to environments - ;; where version numbers and so forth become an issue, it might become - ;; urgent to rewrite this using the fancy Common Lisp PATHNAME - ;; machinery instead of just using strings. In the absence of such a - ;; port, it might or might be a good idea to do the rewrite. - ;; -- WHN 19990815 - (src (stem-source-path stem)) + (let* ((src (stem-source-path stem)) (obj (stem-object-path stem flags mode)) ;; Compile-for-effect happens simultaneously with a forked compile, ;; so we need the for-effect output not to stomp on the real output. (tmp-obj - (concatenate 'string obj - (if *compile-for-effect-only* "-scratch" "-tmp"))) - + (concatenate 'string obj + (if *compile-for-effect-only* "-scratch" "-tmp"))) (compile-file (ecase mode (:host-compile - #+ccl + #+abcl ; ABCL complains about its own deficiency and then returns T + ;; for warnings and failure. "Unable to compile function" is not our problem, + ;; but I tried everything to muffle it, and nothing worked; so if it occurs, + ;; treat the file as a success despite any actual problems that may exist. + (lambda (&rest args) + (let (compiler-bug) + ;; Even though COMPILER-UNSUPPORTED-FEATURE-ERROR is a condition class, + ;; HANDLER-BIND seems unable to match it. What the hell? Bugs all the way down. + (handler-bind ((condition + (lambda (c) + (when (search "Using interpreted form" (princ-to-string c)) + (setq compiler-bug t))))) + (multiple-value-bind (fasl warn err) (apply #'compile-file args) + (if compiler-bug (values fasl nil nil) (values fasl warn err)))))) + #+ccl ; CCL doesn't like NOTINLINE on unknown functions (lambda (&rest args) - ;; CCL doesn't like NOTINLINE on uknown functions (handler-bind ((ccl:compiler-warning (lambda (c) (when (eq (ccl::compiler-warning-warning-type c) :unknown-declaration-function) (muffle-warning c))))) (apply #'compile-file args))) - #-ccl - #'compile-file) + #-(or abcl ccl) #'compile-file) (:target-compile (if (find :assem flags) *target-assemble-file* *target-compile-file*)))) (trace-file (if (find :trace-file flags) t nil)) - (block-compile (if (find :block-compile flags) t :specified)) - (ignore-failure-p (find :ignore-failure-p flags))) + (block-compile (if (find :block-compile flags) t :specified))) (declare (type function compile-file)) (ensure-directories-exist obj :verbose cl:*compile-print*) ; host's value @@ -615,26 +627,27 @@ retry-compile-file (multiple-value-bind (output-truename warnings-p failure-p) (restart-case - (apply compile-file src :output-file tmp-obj - :block-compile (and ;; Block compilation was - ;; completely broken - ;; from the beginning of - ;; SBCL history until - ;; version 2.0.2. - #+sbcl - (or (eq mode :target-compile) - (and (find-symbol "SPLIT-VERSION-STRING" "SB-C") - (funcall (find-symbol "VERSION>=" "SB-C") - (funcall (find-symbol "SPLIT-VERSION-STRING" "SB-C") - (lisp-implementation-version)) - '(2 0 2)))) - block-compile) - :allow-other-keys t - ;; If tracing, also print, but don't specify :PRINT unless specifying - ;; :TRACE-FILE so that whatever the default is for *COMPILE-PRINT* - ;; prevails, insensitively to whether it's the SB-XC: or CL: symbol. - (when trace-file - '(:trace-file t :print t))) + (apply compile-file src + :output-file tmp-obj + :block-compile (and + ;; Block compilation was + ;; completely broken from the + ;; beginning of SBCL history + ;; until version 2.0.2. + #+sbcl + (or (eq mode :target-compile) + (and (find-symbol "SPLIT-VERSION-STRING" "HOST-SB-C") + (funcall (find-symbol "VERSION>=" "HOST-SB-C") + (funcall (find-symbol "SPLIT-VERSION-STRING" "HOST-SB-C") + (lisp-implementation-version)) + '(2 0 2)))) + block-compile) + :allow-other-keys t + ;; If tracing, also print, but don't specify :PRINT unless specifying + ;; :TRACE-FILE so that whatever the default is for *COMPILE-PRINT* + ;; prevails, insensitively to whether it's the SB-XC: or CL: symbol. + (when trace-file + '(:trace-file t :print t))) (recompile () :report report-recompile-restart (go retry-compile-file))) @@ -642,23 +655,20 @@ (cond ((not output-truename) (error "couldn't compile ~S" src)) (failure-p - (if ignore-failure-p - (warn "ignoring FAILURE-P return value from compilation of ~S" - src) - (unwind-protect - (restart-case - (error "FAILURE-P was set when creating ~S." - obj) - (recompile () - :report report-recompile-restart - (go retry-compile-file)) - (continue () - :report report-continue-restart - (setf failure-p nil))) - ;; Don't leave failed object files lying around. - (when (and failure-p (probe-file tmp-obj)) - (delete-file tmp-obj) - (format t "~&deleted ~S~%" tmp-obj))))) + (unwind-protect + (restart-case + (error "FAILURE-P was set when creating ~S." + obj) + (recompile () + :report report-recompile-restart + (go retry-compile-file)) + (continue () + :report report-continue-restart + (setf failure-p nil))) + ;; Don't leave failed object files lying around. + (when (and failure-p (probe-file tmp-obj)) + (delete-file tmp-obj) + (format t "~&deleted ~S~%" tmp-obj)))) ;; Otherwise: success, just fall through. (t nil))))) @@ -667,16 +677,14 @@ (cond ((not *compile-for-effect-only*) (rename-file-a-la-unix tmp-obj obj)) ((probe-file tmp-obj) - (delete-file tmp-obj))) ; clean up the trash + (delete-file tmp-obj))) ; clean up the trash ;; nice friendly traditional return value (pathname obj))) (compile 'compile-stem) (defparameter *host-quirks* - (or #+cmu '(:host-quirks-cmu) - #+ecl '(:host-quirks-ecl) - #+sbcl '(:host-quirks-sbcl))) ; not so much a "quirk", but consistent anyway + (or #+sbcl '(:host-quirks-sbcl))) ; not so much a "quirk", but consistent anyway ;;; Execute function FN in an environment appropriate for compiling the ;;; cross-compiler's source code in the cross-compilation host. @@ -743,6 +751,8 @@ ;;;; Floating-point number reader interceptor (defvar *choke-on-host-irrationals* t) +;;; FIXME: this gets stuck on forms which contain literal CTYPE objects +;;; because of infinite recursion. (defun install-read-interceptor () ;; Intercept READ to catch inadvertent use of host floating-point literals. ;; This prevents regressions in the portable float logic and allows passing @@ -780,7 +790,7 @@ ((and structure-object (not package)) (let ((type-name (string (type-of x)))) ;; This "LAYOUT" refers to *our* object, not host-sb-kernel:layout. - (unless (member type-name '("LAYOUT" "FLOAT" "COMPLEXNUM") + (unless (member type-name '("WRAPPER" "LAYOUT" "FLOAT" "COMPLEXNUM") :test #'string=) ;(Format t "visit a ~/host-sb-ext:print-symbol-with-prefix/~%" (type-of x)) ;; This generalizes over any structure. I need it because we diff -Nru sbcl-2.1.1/src/cold/shebang.lisp sbcl-2.1.11/src/cold/shebang.lisp --- sbcl-2.1.1/src/cold/shebang.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/shebang.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -24,7 +24,7 @@ (declaim (type list sb-xc:*features*)) (defvar sb-xc:*features*) -(defun target-platform-keyword (&optional (features sb-xc:*features*)) +(defun target-platform-keyword (&aux (features sb-xc:*features*)) (let ((arch (intersection '(:arm :arm64 :mips :ppc :ppc64 :riscv :sparc :x86 :x86-64) features))) (cond ((not arch) (error "No architecture selected")) @@ -32,8 +32,7 @@ (car arch))) ;;; Not necessarily the logical place to define BACKEND-ASM-PACKAGE-NAME, -;;; but a convenient one, because sb-xc:*features* needs to have been -;;; DEFVARed, and because 'chill' loads this and only this file. +;;; but a convenient one. (defun backend-assembler-target-name () (let ((keyword (target-platform-keyword))) (case keyword @@ -42,23 +41,19 @@ (defun backend-asm-package-name () (concatenate 'string "SB-" (string (backend-assembler-target-name)) "-ASM")) -;;; We should never call this with a selector of :HOST any more, -;;; but I'm keeping it in case of emergency. -;;; SB-XC:*FEATURES* might not be bound yet when computing derived features. -(defun featurep (feature &optional (list sb-xc:*features*)) +;;; Like the real FEATUREP but using SB-XC:*FEATURES* instead of CL:*FEATURES* +(defun target-featurep (feature) (etypecase feature (symbol (if (string= feature "SBCL") (error "Testing SBCL as a target feature is obviously bogus") - (member feature list :test #'eq))) - (cons (flet ((subfeature-in-list-p (subfeature) - (featurep subfeature list))) - (ecase (first feature) - (:or (some #'subfeature-in-list-p (rest feature))) - (:and (every #'subfeature-in-list-p (rest feature))) - (:not (destructuring-bind (subexpr) (cdr feature) - (not (subfeature-in-list-p subexpr))))))))) -(compile 'featurep) + (member feature sb-xc:*features* :test #'eq))) + (cons (ecase (first feature) + (:or (some #'target-featurep (rest feature))) + (:and (every #'target-featurep (rest feature))) + (:not (destructuring-bind (subexpr) (cdr feature) + (not (target-featurep subexpr)))))))) +(compile 'target-featurep) (defun read-targ-feature-expr (stream sub-character infix-parameter) (when infix-parameter @@ -66,7 +61,7 @@ (if (char= (if (let* ((*package* (find-package "KEYWORD")) (*read-suppress* nil) (feature (read stream t nil t))) - (featurep feature)) + (target-featurep feature)) #\+ #\-) sub-character) (read stream t nil t) @@ -87,19 +82,6 @@ t ; non-terminating so that symbols may contain a dollar sign *xc-readtable*) -;;;; variables like SB-XC:*FEATURES* but different - -;;; This variable is declared here (like SB-XC:*FEATURES*) so that -;;; things like chill.lisp work (because the variable has properties -;;; similar to SB-XC:*FEATURES*, and chill.lisp was set up to work -;;; for that). For an explanation of what it really does, look -;;; elsewhere. -;;; FIXME: Can we just assign SB-C:*BACKEND-SUBFEATURES* directly? -;;; (This has nothing whatsoever to do with the so-called "shebang" reader) -(export '*shebang-backend-subfeatures*) -(declaim (type list *shebang-backend-subfeatures*)) -(defvar *shebang-backend-subfeatures*) - ;;;; string checker, for catching non-portability early ;;; A note about CLISP compatibility: diff -Nru sbcl-2.1.1/src/cold/slam.lisp sbcl-2.1.11/src/cold/slam.lisp --- sbcl-2.1.1/src/cold/slam.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/slam.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -46,7 +46,7 @@ ;;; :trace-file as a flag. (setf *stems-and-flags* (let ((*readtable* *xc-readtable*)) - (read-from-file "build-order.lisp-expr" nil))) + (read-from-file "^build-order.lisp-expr" nil))) ;;; Don't care about deftransforms that get redefined. ;;; The target condition is defined in 'condition' which is a :not-host file. diff -Nru sbcl-2.1.1/src/cold/warm.lisp sbcl-2.1.11/src/cold/warm.lisp --- sbcl-2.1.1/src/cold/warm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/cold/warm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -127,8 +127,8 @@ ;;; ((:or :macro (:match "$EARLY-") (:match "$BOOT-")) ;;; (declare (optimize (speed 0)))))) ;;; -(let ((sources (with-open-file (f (merge-pathnames "../../build-order.lisp-expr" - *load-pathname*)) +(defvar *sbclroot* "") +(let ((sources (with-open-file (f (merge-pathnames "build-order.lisp-expr" *load-pathname*)) (read f) ; skip over the make-host-{1,2} input files (read f))) (sb-c::*handled-conditions* sb-c::*handled-conditions*)) @@ -143,7 +143,8 @@ ;; a literal (when compiling in the LOAD step) t)) (output - (compile-file-pathname stem + (compile-file-pathname + (concatenate 'string *sbclroot* stem) :output-file (merge-pathnames (concatenate @@ -170,7 +171,8 @@ (safety 2) (speed 2) (sb-c:insert-step-conditions 0) (sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0))) - (compile-file stem :output-file output))) + (compile-file (concatenate 'string *sbclroot* stem) + :output-file output))) ((nil) output)) (cond ((not output-truename) (error "COMPILE-FILE of ~S failed." stem)) @@ -205,7 +207,12 @@ (let ((cl:*compile-print* nil)) (dolist (group sources) - (handler-bind ((#+x86-64 warning #-x86-64 simple-warning + ;; For the love of god, what are we trying to do here??? + ;; It's gone through so many machinations that I can't figure it out. + ;; The goal should be to build warning-free, not layer one + ;; kludge upon another so that it can be allowed not to. + (handler-bind (((and #+x86-64 warning #-x86-64 simple-warning + (not sb-kernel:redefinition-warning)) (lambda (c) ;; escalate "undefined variable" warnings to errors. ;; There's no reason to allow them in our code. diff -Nru sbcl-2.1.1/src/compiler/aliencomp.lisp sbcl-2.1.11/src/compiler/aliencomp.lisp --- sbcl-2.1.1/src/compiler/aliencomp.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/aliencomp.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -66,7 +66,7 @@ (defknown (setf %alien-value) (t system-area-pointer unsigned-byte alien-type) t ()) -(defknown alien-funcall (alien-value &rest *) * +(defknown alien-funcall (alien-value &rest t) * (any recursive)) (defknown sb-alien::string-to-c-string (simple-string t) (or (simple-array (unsigned-byte 8) (*)) @@ -219,7 +219,7 @@ (give-up-ir1-transform "Element alignment is unknown.")) (if (null dims) (values nil 0 element-type) - (let* ((arg (gensym)) + (let* ((arg (sb-xc:gensym)) (args (list arg)) (offsetexpr arg)) (dolist (dim (cdr dims)) @@ -321,7 +321,7 @@ (return type)))) *wild-type*)) -(deftransform %set-heap-alien ((info value) (heap-alien-info *) *) +(deftransform %set-heap-alien ((info value) (heap-alien-info t) *) (multiple-value-bind (sap type) (heap-alien-sap-and-type info) `(setf (%alien-value ,sap 0 ',type) value))) @@ -503,7 +503,7 @@ ;;;; ALIEN-FUNCALL support (deftransform alien-funcall ((function &rest args) - ((alien (* t)) &rest *) *) + ((alien (* t)) &rest t) *) (let ((names (make-gensym-list (length args)))) (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args) `(lambda (function ,@names) @@ -598,11 +598,10 @@ (unless (and (constant-lvar-p type) (alien-fun-type-p (lvar-value type))) (error "Something is broken.")) - (let ((type (lvar-value type))) - (values-specifier-type - (compute-alien-rep-type - (alien-fun-type-result-type type) - :result)))) + (let ((spec (compute-alien-rep-type + (alien-fun-type-result-type (lvar-value type)) + :result))) + (if (eq spec '*) *wild-type* (values-specifier-type spec)))) (defoptimizer (%alien-funcall ltn-annotate) ((function type &rest args) node ltn-policy) @@ -651,59 +650,68 @@ ;; KLUDGE: This is where the second half of the ARM ;; register-pressure change lives (see above). (dolist (tn #-arm arg-tns #+arm (reverse arg-tns)) - ;; On PPC, TN might be a list. This is used to indicate - ;; something special needs to happen. See below. - ;; - ;; FIXME: We should implement something better than this. - (let* ((first-tn (if (listp tn) (car tn) tn)) - (arg (pop args)) - (sc (tn-sc first-tn)) - (scn (sc-number sc)) - (move-arg-vops (svref (sc-move-arg-vops sc) scn))) - (aver arg) - (unless (= (length move-arg-vops) 1) - (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc))) - #+(or x86 x86-64) (emit-move-arg-template call - block - (first move-arg-vops) - (lvar-tn call block arg) - nsp - first-tn) - #-(or x86 x86-64) - (cond - #+arm-softfp - ((and (proper-list-of-length-p tn 3) - (symbolp (third tn))) - (emit-template call block - (template-or-lose (third tn)) - (reference-tn (lvar-tn call block arg) nil) - (reference-tn-list (butlast tn) t))) - (t - (let ((temp-tn (make-representation-tn - (tn-primitive-type first-tn) scn))) - (emit-move call - block - (lvar-tn call block arg) - temp-tn) - (emit-move-arg-template call - block - (first move-arg-vops) - temp-tn - nsp - first-tn)))) - #+(and ppc darwin) - (when (listp tn) - ;; This means that we have a float arg that we need to - ;; also copy to some int regs. The list contains the TN - ;; for the float as well as the TNs to use for the int - ;; arg. - (destructuring-bind (float-tn i1-tn &optional i2-tn) - tn - (if i2-tn - (vop sb-vm::move-double-to-int-arg call block - float-tn i1-tn i2-tn) - (vop sb-vm::move-single-to-int-arg call block - float-tn i1-tn)))))) + (if (functionp tn) + (funcall tn (pop args) call block nsp) + ;; On PPC, TN might be a list. This is used to indicate + ;; something special needs to happen. See below. + ;; + ;; FIXME: We should implement something better than this. + (let* ((first-tn (if (listp tn) (car tn) tn)) + (arg (pop args)) + (sc (tn-sc first-tn)) + (scn (sc-number sc)) + (move-arg-vops (svref (sc-move-arg-vops sc) scn))) + (aver arg) + (unless (= (length move-arg-vops) 1) + (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc))) + + (cond + #+arm-softfp + ((and (listp tn) + (symbolp (car (last tn)))) + (emit-template call block + (template-or-lose (car (last tn))) + (reference-tn (lvar-tn call block arg) nil) + (reference-tn-list (butlast tn) t))) + (t + (when (eq (sb-kind (sc-sb sc)) :unbounded) ;; stacks are unbounded + ;; Avoid allocating this TN on the caller's stack + (setf (tn-kind first-tn) :arg-pass)) + #+(or x86 x86-64) + (emit-move-arg-template call + block + (first move-arg-vops) + (lvar-tn call block arg) + nsp + first-tn) + #-(or x86 x86-64) + (let* ((primitive-type (tn-primitive-type first-tn)) + ;; If the destination is a stack TN make sure + ;; the temporary TN is a register. + (scn (if (sc-number-stack-p sc) + (car (primitive-type-scs primitive-type)) + scn)) + (temp-tn (make-representation-tn primitive-type scn))) + (emit-move call block (lvar-tn call block arg) temp-tn) + (emit-move-arg-template call + block + (first move-arg-vops) + temp-tn + nsp + first-tn)))) + #+(and ppc darwin) + (when (listp tn) + ;; This means that we have a float arg that we need to + ;; also copy to some int regs. The list contains the TN + ;; for the float as well as the TNs to use for the int + ;; arg. + (destructuring-bind (float-tn i1-tn &optional i2-tn) + tn + (if i2-tn + (vop sb-vm::move-double-to-int-arg call block + float-tn i1-tn i2-tn) + (vop sb-vm::move-single-to-int-arg call block + float-tn i1-tn))))))) (aver (null args)) (let* ((result-tns (ensure-list result-tns)) (arg-operands @@ -728,12 +736,12 @@ (cond #+arm-softfp ((and lvar - (fourth result-tns)) + (symbolp (car (last result-tns)))) (emit-template call block - (template-or-lose (fourth result-tns)) + (template-or-lose (car (last result-tns))) (reference-tn-list (butlast result-tns 2) nil) - (reference-tn (third result-tns) t)) - (move-lvar-result call block (list (third result-tns)) lvar)) + (reference-tn (car (last result-tns 2)) t)) + (move-lvar-result call block (list (car (last result-tns 2))) lvar)) (t (move-lvar-result call block result-tns lvar))))))) diff -Nru sbcl-2.1.1/src/compiler/arm/alloc.lisp sbcl-2.1.11/src/compiler/arm/alloc.lisp --- sbcl-2.1.1/src/compiler/arm/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,26 +11,18 @@ (in-package "SB-VM") -(define-vop (list-or-list*) +(define-vop (list) (:args (things :more t :scs (control-stack))) (:temporary (:scs (descriptor-reg)) ptr) (:temporary (:scs (any-reg)) temp) (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) res) (:temporary (:sc non-descriptor-reg :offset ocfp-offset) pa-flag) - (:info num) + (:info star cons-cells) (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :fast-safe) (:node-var node) (:generator 0 - (cond ((zerop num) - (move result null-tn)) - ((and star (= num 1)) - (move result (tn-ref-tn things))) - (t - (macrolet - ((maybe-load (tn) + (macrolet ((maybe-load (tn) (once-only ((tn tn)) `(sc-case ,tn ((any-reg descriptor-reg null) @@ -38,9 +30,8 @@ (control-stack (load-stack-tn temp ,tn) temp))))) - (let* ((cons-cells (if star (1- num) num)) - (alloc (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (pa-flag) + (let ((alloc (* (pad-data-block cons-size) cons-cells))) + (pseudo-atomic (pa-flag) (allocation 'list alloc list-pointer-lowtag res :flag-tn pa-flag :stack-allocate-p (node-stack-allocate-p node)) @@ -59,13 +50,7 @@ (maybe-load (tn-ref-tn (tn-ref-across things))) null-tn) ptr cons-cdr-slot list-pointer-lowtag)) - (move result res))))))) - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) + (move result res))))) ;;;; Special purpose inline allocators. diff -Nru sbcl-2.1.1/src/compiler/arm/array.lisp sbcl-2.1.11/src/compiler/arm/array.lisp --- sbcl-2.1.1/src/compiler/arm/array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -36,7 +36,7 @@ ;; See ENCODE-ARRAY-RANK. (inst sub ndescr rank (fixnumize 1)) (inst and ndescr ndescr (fixnumize array-rank-mask)) - (inst orr ndescr type (lsl ndescr array-rank-byte-pos)) + (inst orr ndescr type (lsl ndescr array-rank-position)) (inst mov ndescr (lsr ndescr n-fixnum-tag-bits)) ;; And store the header value. (storew ndescr header 0 other-pointer-lowtag)) @@ -183,10 +183,8 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (unsigned-reg) :target shift) - (value :scs (unsigned-reg immediate) :target result)) + (value :scs (unsigned-reg immediate))) (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) (:temporary (:scs (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg)) temp old) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) @@ -220,13 +218,7 @@ ;; Write the altered word back to the array. (inst str old (@ lip (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))) - ;; And present the result properly. - (sc-case value - (immediate - (inst mov result (tn-value value))) - (unsigned-reg - (move result value))))))))) + other-pointer-lowtag))))))))) (def-small-data-vector-frobs simple-bit-vector 1) (def-small-data-vector-frobs simple-array-unsigned-byte-2 2) (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)) @@ -255,18 +247,14 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg)) - (value :scs (single-reg) :target result)) + (value :scs (single-reg))) (:arg-types simple-array-single-float positive-fixnum single-float) - (:results (result :scs (single-reg))) - (:result-types single-float) (:temporary (:scs (interior-reg)) lip) (:generator 5 (inst add lip object (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) (inst add lip lip index) - (inst fsts value (@ lip)) - (unless (location= result value) - (inst fcpys result value)))) + (inst fsts value (@ lip)))) (define-vop (data-vector-ref/simple-array-double-float) (:note "inline array access") @@ -290,18 +278,14 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg)) - (value :scs (double-reg) :target result)) + (value :scs (double-reg))) (:arg-types simple-array-double-float positive-fixnum double-float) - (:results (result :scs (double-reg))) - (:result-types double-float) (:temporary (:scs (interior-reg)) lip) (:generator 20 (inst add lip object (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) (inst add lip lip (lsl index 1)) - (inst fstd value (@ lip)) - (unless (location= result value) - (inst fcpyd result value)))) + (inst fstd value (@ lip)))) ;;; Complex float arrays. @@ -330,26 +314,16 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to :result) (index :scs (any-reg)) - (value :scs (complex-single-reg) :target result)) + (value :scs (complex-single-reg))) (:arg-types simple-array-complex-single-float positive-fixnum complex-single-float) - (:results (result :scs (complex-single-reg))) - (:result-types complex-single-float) (:temporary (:scs (interior-reg)) lip) (:generator 5 - (let ((value-real (complex-single-reg-real-tn value)) - (result-real (complex-single-reg-real-tn result))) - (inst add lip object (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - (inst add lip lip (lsl index 1)) - (inst fsts value-real (@ lip)) - (unless (location= result-real value-real) - (inst fcpys result-real value-real))) - (let ((value-imag (complex-single-reg-imag-tn value)) - (result-imag (complex-single-reg-imag-tn result))) - (inst fsts value-imag (@ lip n-word-bytes)) - (unless (location= result-imag value-imag) - (inst fcpys result-imag value-imag))))) + (inst add lip object (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag)) + (inst add lip lip (lsl index 1)) + (inst fsts (complex-single-reg-real-tn value) (@ lip)) + (inst fsts (complex-single-reg-imag-tn value) (@ lip n-word-bytes)))) (define-vop (data-vector-ref/simple-array-complex-double-float) (:note "inline array access") @@ -376,26 +350,16 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to :result) (index :scs (any-reg)) - (value :scs (complex-double-reg) :target result)) + (value :scs (complex-double-reg))) (:arg-types simple-array-complex-double-float positive-fixnum complex-double-float) - (:results (result :scs (complex-double-reg))) - (:result-types complex-double-float) (:temporary (:scs (interior-reg)) lip) (:generator 20 - (let ((value-real (complex-double-reg-real-tn value)) - (result-real (complex-double-reg-real-tn result))) - (inst add lip object (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag)) - (inst add lip lip (lsl index 2)) - (inst fstd value-real (@ lip)) - (unless (location= result-real value-real) - (inst fcpyd result-real value-real))) - (let ((value-imag (complex-double-reg-imag-tn value)) - (result-imag (complex-double-reg-imag-tn result))) - (inst fstd value-imag (@ lip (* 2 n-word-bytes))) - (unless (location= result-imag value-imag) - (inst fcpyd result-imag value-imag))))) + (inst add lip object (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag)) + (inst add lip lip (lsl index 2)) + (inst fstd (complex-double-reg-real-tn value) (@ lip)) + (inst fstd (complex-double-reg-imag-tn value) (@ lip (* 2 n-word-bytes))))) ;;; These vops are useful for accessing the bits of a vector irrespective of ;;; what type of vector it is. diff -Nru sbcl-2.1.1/src/compiler/arm/call.lisp sbcl-2.1.11/src/compiler/arm/call.lisp --- sbcl-2.1.1/src/compiler/arm/call.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,48 +14,31 @@ (defconstant arg-count-sc (make-sc+offset immediate-arg-scn nargs-offset)) (defconstant closure-sc (make-sc+offset descriptor-reg-sc-number lexenv-offset)) -;;; Always wire the return PC location to the stack in its standard -;;; location. -(defun make-return-pc-passing-location (standard) - (declare (ignore standard)) - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset)) - (defconstant return-pc-passing-offset (make-sc+offset control-stack-sc-number lra-save-offset)) -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. -;;; -;;; This is wired in both the standard and the local-call conventions, -;;; because we want to be able to assume it's always there. Besides, -;;; the ARM doesn't have enough registers to really make it profitable -;;; to pass it in a register. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* control-stack-sc-number - ocfp-save-offset)) - (defconstant old-fp-passing-offset (make-sc+offset control-stack-sc-number ocfp-save-offset)) ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current ;;; function. We treat these specially so that the debugger can find ;;; them at a known location. -(defun make-old-fp-save-location (env) +(defun make-old-fp-save-location () ;; Unlike the other backends, ARM function calling is designed to ;; pass OLD-FP within the stack frame rather than in a register. As ;; such, in order for lifetime analysis not to screw up, we need it ;; to be a stack TN wired to the save offset, not a normal TN with a ;; wired SAVE-TN. - (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset) - env)) -(defun make-return-pc-save-location (physenv) - (physenv-debug-live-tn - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset) - physenv)) + (let ((tn (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) + (setf (tn-kind tn) :environment) + tn)) +(defun make-return-pc-save-location () + (let ((tn (make-wired-tn *backend-t-primitive-type* control-stack-sc-number + lra-save-offset))) + (setf (tn-kind tn) :environment) + tn)) ;;; Make a TN for the standard argument count passing location. We ;;; only need to make the standard location, since a count is never @@ -151,7 +134,7 @@ (* (max 1 (sb-allocated-size 'control-stack)) n-word-bytes)) (store-csp nfp) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (let* ((nbytes (bytes-needed-for-non-descriptor-stack-frame))) (inst sub nfp nsp-tn nbytes) (inst mov nsp-tn nfp))))) @@ -309,8 +292,7 @@ values-start) (:temporary (:sc any-reg :offset nargs-offset :from :eval :to (:result 1)) - nvals) - (:temporary (:scs (non-descriptor-reg)) temp)) + nvals)) ;;; This hook in the codegen pass lets us insert code before fall-thru entry ;;; points, local-call entry points, and tail-call entry points. The default diff -Nru sbcl-2.1.1/src/compiler/arm/c-call.lisp sbcl-2.1.11/src/compiler/arm/c-call.lisp --- sbcl-2.1.1/src/compiler/arm/c-call.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -55,7 +55,17 @@ #+arm-softfp (define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) - (int-arg state 'single-float unsigned-reg-sc-number single-stack-sc-number)) + (let ((register (arg-state-num-register-args state))) + (cond ((>= register +max-register-args+) + (let ((frame-size (arg-state-stack-frame-size state))) + (incf (arg-state-stack-frame-size state)) + (make-wired-tn* 'single-float single-stack-sc-number frame-size))) + (t + (incf (arg-state-num-register-args state)) + (list + (make-wired-tn* 'unsigned-byte-32 unsigned-reg-sc-number + (register-args-offset register)) + 'move-single-to-int-args))))) #-arm-softfp (define-alien-type-method (single-float :arg-tn) (type state) @@ -123,7 +133,9 @@ #+arm-softfp (define-alien-type-method (single-float :result-tn) (type state) (declare (ignore type state)) - (make-wired-tn* 'single-float unsigned-reg-sc-number nargs-offset)) + (list (make-wired-tn* 'unsigned-byte-32 unsigned-reg-sc-number nargs-offset) + (make-normal-tn (primitive-type-or-lose 'single-float)) + 'move-int-args-to-single)) #-arm-softfp (define-alien-type-method (single-float :result-tn) (type state) @@ -247,31 +259,51 @@ ;;; #+arm-softfp -(define-vop (move-double-to-int-args) - (:args (double :scs (double-reg))) - (:results (lo-bits :scs (unsigned-reg)) - (hi-bits :scs (unsigned-reg))) - (:arg-types double-float) - (:result-types unsigned-num unsigned-num) - (:policy :fast-safe) - (:generator 1 - (inst fmrrd lo-bits hi-bits double))) - -#+arm-softfp -(define-vop (move-int-args-to-double) - (:args (lo-bits :scs (unsigned-reg)) - (hi-bits :scs (unsigned-reg))) - (:results (double :scs (double-reg))) - (:arg-types unsigned-num unsigned-num) - (:result-types double-float) - (:policy :fast-safe) - (:generator 1 - (inst fmdrr double lo-bits hi-bits))) +(progn + (define-vop (move-double-to-int-args) + (:args (double :scs (double-reg))) + (:results (lo-bits :scs (unsigned-reg)) + (hi-bits :scs (unsigned-reg))) + (:arg-types double-float) + (:result-types unsigned-num unsigned-num) + (:policy :fast-safe) + (:generator 1 + (inst fmrrd lo-bits hi-bits double))) + + + (define-vop (move-int-args-to-double) + (:args (lo-bits :scs (unsigned-reg)) + (hi-bits :scs (unsigned-reg))) + (:results (double :scs (double-reg))) + (:arg-types unsigned-num unsigned-num) + (:result-types double-float) + (:policy :fast-safe) + (:generator 1 + (inst fmdrr double lo-bits hi-bits))) + + (define-vop (move-single-to-int-args) + (:args (single :scs (single-reg))) + (:results (bits :scs (unsigned-reg))) + (:arg-types single-float) + (:result-types unsigned-num) + (:policy :fast-safe) + (:generator 1 + (inst fmrs bits single))) + + + (define-vop (move-int-args-to-single) + (:args (bits :scs (unsigned-reg))) + (:results (single :scs (single-reg))) + (:arg-types unsigned-num) + (:result-types single-float) + (:policy :fast-safe) + (:generator 1 + (inst fmsr single bits)))) ;;; long-long support (deftransform %alien-funcall ((function type &rest args) * * :node node) - (aver (sb-c::constant-lvar-p type)) - (let* ((type (sb-c::lvar-value type)) + (aver (sb-c:constant-lvar-p type)) + (let* ((type (sb-c:lvar-value type)) (env (sb-c::node-lexenv node)) (arg-types (alien-fun-type-arg-types type)) (result-type (alien-fun-type-result-type type))) diff -Nru sbcl-2.1.1/src/compiler/arm/cell.lisp sbcl-2.1.11/src/compiler/arm/cell.lisp --- sbcl-2.1.1/src/compiler/arm/cell.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -30,10 +30,6 @@ (:results) (:generator 1 (storew value object offset lowtag))) - -(define-vop (init-slot set-slot) - (:info name dx-p offset lowtag) - (:ignore name dx-p)) ;;;; Symbol hacking VOPs: @@ -65,14 +61,12 @@ (inst b :eq err-lab)))) ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) +(define-vop (boundp) (:args (object :scs (descriptor-reg))) (:conditional) (:info target not-p) (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) - -(define-vop (boundp boundp-frob) + (:temporary (:scs (descriptor-reg)) value) (:translate boundp) (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) @@ -150,10 +144,9 @@ (define-vop (fdefn-makunbound) (:policy :fast-safe) (:translate fdefn-makunbound) - (:args (fdefn :scs (descriptor-reg) :target result)) + (:args (fdefn :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (interior-reg)) lip) - (:results (result :scs (descriptor-reg))) (:generator 38 (let ((undefined-tramp-fixup (gen-label))) (assemble (:elsewhere) @@ -161,9 +154,7 @@ (inst word (make-fixup 'undefined-tramp :assembly-routine))) (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) (inst load-from-label temp lip undefined-tramp-fixup) - (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) - (move result fdefn)))) - + (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)))) ;;;; Binding and Unbinding. @@ -234,9 +225,9 @@ closure-info-offset fun-pointer-lowtag (descriptor-reg any-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg null) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * + closure-info-offset fun-pointer-lowtag + (descriptor-reg any-reg null) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag @@ -293,8 +284,46 @@ (define-full-reffer code-header-ref * 0 other-pointer-lowtag (descriptor-reg any-reg) * code-header-ref) -(define-full-setter code-header-set * 0 other-pointer-lowtag - (descriptor-reg any-reg null) * code-header-set) +(define-vop (code-header-set) + (:translate code-header-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) pa-flag) + (:generator 10 + (let ((mask-fixup-label (gen-label)) + (table-fixup-label (gen-label))) + (inst load-from-label temp lip mask-fixup-label) + (inst ldr temp (@ temp)) + (inst ldr temp (@ temp)) + (pseudo-atomic (pa-flag) + ;; Compute card mark index + (inst mov card (lsr object gencgc-card-shift)) + (inst and card card temp) + ;; Load mark table base + (inst load-from-label temp lip table-fixup-label) + (inst ldr temp (@ temp)) + (inst ldr temp (@ temp)) + ;; Touch the card mark byte. + (inst mov lip 0) + (inst strb lip (@ temp card)) + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte (- #+little-endian 3 other-pointer-lowtag))) + (inst ldrb temp (@ object byte)) + (inst orr temp temp #x40) + (inst strb temp (@ object byte))) + (inst sub temp index other-pointer-lowtag) + (inst str value (@ object temp))) + (assemble (:elsewhere) + (emit-label mask-fixup-label) + (inst word (make-fixup "gc_card_table_mask" :foreign-dataref)) + (emit-label table-fixup-label) + (inst word (make-fixup "gc_card_mark" :foreign-dataref)))))) ;;;; raw instance slot accessors @@ -311,11 +340,9 @@ `((inst ,instruction value (@ object offset)))) ,@(when move-result `((,move-macro result value)))))) - (let ((ref-vop (symbolicate "RAW-INSTANCE-REF/" name)) - (set-vop (symbolicate "RAW-INSTANCE-SET/" name))) `(progn - (define-vop (,ref-vop) - (:translate ,(symbolicate "%" ref-vop)) + (define-vop () + (:translate ,(symbolicate "%RAW-INSTANCE-REF/" name)) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg))) @@ -325,18 +352,16 @@ (:temporary (:scs (non-descriptor-reg)) offset) ,@(when use-lip '((:temporary (:scs (interior-reg)) lip))) (:generator 5 ,@(emit-generator ref-inst nil))) - (define-vop (,set-vop) - (:translate ,(symbolicate "%" set-vop)) + (define-vop () + (:translate ,(symbolicate "%RAW-INSTANCE-SET/" name)) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg)) - (value :scs (,value-sc) :target result)) + (value :scs (,value-sc))) (:arg-types * positive-fixnum ,value-primtype) - (:results (result :scs (,value-sc))) - (:result-types ,value-primtype) (:temporary (:scs (non-descriptor-reg)) offset) ,@(when use-lip '((:temporary (:scs (interior-reg)) lip))) - (:generator 5 ,@(emit-generator set-inst t)))))))) + (:generator 5 ,@(emit-generator set-inst nil))))))) (define-raw-slot-vops word ldr str unsigned-num unsigned-reg) (define-raw-slot-vops signed-word ldr str signed-num signed-reg) (define-raw-slot-vops single flds fsts single-float single-reg diff -Nru sbcl-2.1.1/src/compiler/arm/debug.lisp sbcl-2.1.11/src/compiler/arm/debug.lisp --- sbcl-2.1.1/src/compiler/arm/debug.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/debug.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -19,7 +19,7 @@ (:generator 1 (load-csp res))) -(define-vop () +(define-vop (current-fp-sap) (:translate current-fp) (:policy :fast-safe) (:results (res :scs (sap-reg))) @@ -43,13 +43,10 @@ (:policy :fast-safe) (:args (sap :scs (sap-reg)) (offset :scs (any-reg)) - (value :scs (descriptor-reg) :target result)) + (value :scs (descriptor-reg))) (:arg-types system-area-pointer positive-fixnum *) - (:results (result :scs (descriptor-reg))) - (:result-types *) (:generator 5 - (inst str value (@ sap offset)) - (move result value))) + (inst str value (@ sap offset)))) (define-vop (code-from-mumble) (:policy :fast-safe) diff -Nru sbcl-2.1.1/src/compiler/arm/insts.lisp sbcl-2.1.11/src/compiler/arm/insts.lisp --- sbcl-2.1.1/src/compiler/arm/insts.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,7 +14,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;; Imports from this package into SB-VM - (import '(conditional-opcode emit-word + (import '(conditional-opcode negate-condition emit-word composite-immediate-instruction encodable-immediate lsl lsr asr ror cpsr @) "SB-VM") ;; Imports from SB-VM into this package @@ -40,7 +40,7 @@ (:le . 13) (:al . 14)) #'equal) -(defconstant-eqx sb-vm::+condition-name-vec+ +(defconstant-eqx +condition-name-vec+ #.(let ((vec (make-array 16 :initial-element nil))) (dolist (cond +conditions+ vec) (when (null (aref vec (cdr cond))) @@ -49,6 +49,9 @@ (defun conditional-opcode (condition) (cdr (assoc condition +conditions+ :test #'eq))) +(defun negate-condition (name) + (let ((code (logxor 1 (conditional-opcode name)))) + (aref +condition-name-vec+ code))) ;;;; disassembler field definitions @@ -716,6 +719,31 @@ (define-data-processing-instruction movs #x1b t nil) (define-data-processing-instruction mvn #x1e t nil) (define-data-processing-instruction mvns #x1f t nil) + +(define-instruction-format (movw-format 32 + :default-printer '(:name :tab rd ", #" immediate)) + (cond :field (byte 4 28) :type 'condition-code) + (opcode-8 :field (byte 8 20)) + (immediate :fields (list (byte 4 16) (byte 12 0)) + :prefilter (lambda (dstate high low) + (declare (ignore dstate)) + (logior (ash high 12) low))) + (rd :field (byte 4 12) :type 'reg)) + +(macrolet ((mov-imm-16 (segment rd imm half) + `(emit-dp-instruction ,segment 14 #b00 #b1 + ,(ecase half + (:low #b10000) + (:high #b10100)) + (ldb (byte 4 12) ,imm) + (tn-offset ,rd) + (ldb (byte 12 0) ,imm)))) +(define-instruction movw (segment rd imm) ; move wide (zero-extend) + (:printer movw-format ((opcode-8 #b00110000))) + (:emitter (mov-imm-16 segment rd imm :low))) +(define-instruction movt (segment rd imm) ; move top bits (and keep bottom) + (:printer movw-format ((opcode-8 #b00110100))) + (:emitter (mov-imm-16 segment rd imm :high)))) ;;;; Exception-generating instructions @@ -1760,3 +1788,22 @@ (:absolute (setf (sap-ref-32 sap offset) value)))) nil) + +(define-instruction store-coverage-mark (segment path-index temp) + (:emitter + ;; No backpatch is needed to compute the offset into the code header + ;; because COMPONENT-HEADER-LENGTH is known at this point. + (let* ((offset (+ (component-header-length) + n-word-bytes ; skip over jump table word + path-index + (- other-pointer-lowtag))) + (addr + (@ sb-vm::code-tn + (etypecase offset + ((integer 0 4095) offset) + ((unsigned-byte 31) + (inst* segment 'movw temp (logand offset #xffff)) + (when (ldb-test (byte 16 16) offset) + (inst* segment 'movt temp (ldb (byte 16 16) offset))) + temp))))) + (inst* segment 'strb sb-vm::null-tn addr)))) diff -Nru sbcl-2.1.1/src/compiler/arm/macros.lisp sbcl-2.1.11/src/compiler/arm/macros.lisp --- sbcl-2.1.1/src/compiler/arm/macros.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -356,15 +356,12 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg)) - (value :scs ,scs :target result)) + (value :scs ,scs)) (:arg-types ,type tagged-num ,el-type) (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) (:generator 2 (inst add lip object index) - (storew value lip ,offset ,lowtag) - (move result value)))) + (storew value lip ,offset ,lowtag)))) (defmacro define-partial-reffer (name type size signed offset lowtag scs el-type &optional translate) @@ -395,15 +392,12 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (unsigned-reg)) - (value :scs ,scs :target result)) + (value :scs ,scs)) (:arg-types ,type positive-fixnum ,el-type) (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) (:generator 5 ,(if (eq size :byte) '(inst add lip object index) '(inst add lip object (lsl index 1))) (inst ,(ecase size (:byte 'strb) (:short 'strh)) - value (@ lip (- (* ,offset n-word-bytes) ,lowtag))) - (move result value)))) + value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))) diff -Nru sbcl-2.1.1/src/compiler/arm/nlx.lisp sbcl-2.1.11/src/compiler/arm/nlx.lisp --- sbcl-2.1.1/src/compiler/arm/nlx.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -182,6 +182,21 @@ (load-stack-tn move-temp sp) (store-csp move-temp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:temporary (:scs (descriptor-reg)) move-temp) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-return-pc label) + (note-this-location vop :non-local-entry) + (move res value) + (load-stack-tn move-temp sp) + (store-csp move-temp))) + (define-vop (nlx-entry-multiple) (:args (top :target result) (src) (count)) ;; Again, no SC restrictions for the args, 'cause the loading would diff -Nru sbcl-2.1.1/src/compiler/arm/parms.lisp sbcl-2.1.11/src/compiler/arm/parms.lisp --- sbcl-2.1.1/src/compiler/arm/parms.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/parms.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -41,34 +41,6 @@ ;;; address space) (defconstant n-machine-word-bits 32) -;;; Floating-point related constants, both format descriptions and FPU -;;; control register descriptions. These don't exactly match up with -;;; what the machine manuals say because the Common Lisp standard -;;; defines floating-point values somewhat differently than the IEEE -;;; standard does. - -(defconstant float-sign-shift 31) - -(defconstant single-float-bias 126) -(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp) -(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp) -(defconstant single-float-normal-exponent-min 1) -(defconstant single-float-normal-exponent-max 254) -(defconstant single-float-hidden-bit (ash 1 23)) - -(defconstant double-float-bias 1022) -(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp) -(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp) -(defconstant double-float-normal-exponent-min 1) -(defconstant double-float-normal-exponent-max #x7FE) -(defconstant double-float-hidden-bit (ash 1 20)) - -(defconstant single-float-digits - (+ (byte-size single-float-significand-byte) 1)) - -(defconstant double-float-digits - (+ (byte-size double-float-significand-byte) n-word-bits 1)) - #+arm-vfp (progn (defconstant float-invalid-trap-bit (ash 1 0)) diff -Nru sbcl-2.1.1/src/compiler/arm/pred.lisp sbcl-2.1.11/src/compiler/arm/pred.lisp --- sbcl-2.1.1/src/compiler/arm/pred.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/pred.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -30,15 +30,12 @@ (define-vop (branch-if) (:info dest not-p flags) (:generator 0 - (flet ((negate-condition (name) - (let ((code (logxor 1 (conditional-opcode name)))) - (aref +condition-name-vec+ code)))) (aver (null (rest flags))) (inst b (if not-p (negate-condition (first flags)) (first flags)) - dest)))) + dest))) (defun convert-conditional-move-p (node dst-tn x-tn y-tn) (declare (ignore node dst-tn x-tn y-tn)) diff -Nru sbcl-2.1.1/src/compiler/arm/sap.lisp sbcl-2.1.11/src/compiler/arm/sap.lisp --- sbcl-2.1.1/src/compiler/arm/sap.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/sap.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -151,15 +151,12 @@ ;; be sign-magnitude encoded. FIXME: Figure these ;; things out, and re-enable the VOPs. (ref-name set-name sc type size &key signed use-lip) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C"))) - (declare (ignorable ref-name-c set-name-c)) - `(progn + `(progn (define-vop (,ref-name) (:translate ,ref-name) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) + (offset :scs (signed-reg))) (:arg-types system-area-pointer signed-num) (:results (result :scs (,sc))) (:result-types ,type) @@ -178,8 +175,8 @@ '(@ lip) '(@ sap offset))))) #+(or) - (define-vop (,ref-name-c) - (:translate ,ref-name) + (define-vop (,(symbolicate ref-name "-C")) + (:translate ,ref-name) (:policy :fast-safe) (:args (sap :scs (sap-reg))) (:arg-types system-area-pointer (:constant (signed-byte 16))) @@ -195,14 +192,12 @@ (:double 'fldd)) result (@ sap offset)))) (define-vop (,set-name) - (:translate ,set-name) + (:translate ,set-name) (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer signed-num ,type) - (:results (result :scs (,sc))) - (:result-types ,type) + (:args (value :scs (,sc)) + (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types ,type system-area-pointer signed-num) ,@(when use-lip '((:temporary (:sc interior-reg) lip))) (:generator 5 @@ -216,25 +211,15 @@ (:double 'fstd)) value ,(if use-lip '(@ lip) - '(@ sap offset))) - (unless (location= result value) - ,@(case size - (:single - '((inst fcpys result value))) - (:double - '((inst fcpyd result value))) - (t - '((inst mov result value))))))) + '(@ sap offset))))) #+(or) - (define-vop (,set-name-c) - (:translate ,set-name) + (define-vop (,(symbolicate set-name "-C")) + (:translate ,set-name) (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer (:constant (signed-byte 16)) ,type) + (:args (value :scs (,sc)) + (sap :scs (sap-reg))) + (:arg-types ,type system-area-pointer (:constant (signed-byte 16))) (:info offset) - (:results (result :scs (,sc))) - (:result-types ,type) (:generator 4 (inst ,(ecase size (:byte 'strb) @@ -242,15 +227,7 @@ (:long 'str) (:single 'fsts) (:double 'fstd)) - value (@ sap offset)) - (unless (location= result value) - ,@(case size - (:single - '((inst fcpys result value))) - (:double - '((inst fcpyd result value))) - (t - '((inst mov result value))))))))))) + value (@ sap offset))))))) (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 unsigned-reg positive-fixnum :byte :signed nil) (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 diff -Nru sbcl-2.1.1/src/compiler/arm/system.lisp sbcl-2.1.11/src/compiler/arm/system.lisp --- sbcl-2.1.1/src/compiler/arm/system.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -69,10 +69,8 @@ (:temporary (:sc unsigned-reg) this-id) (:generator 4 (let ((test-id (layout-id test-layout)) - (offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0) - instance-slots-offset) - word-shift) - (ash (- (layout-depthoid test-layout) 2) 2) + (offset (+ (id-bits-offset) + (ash (- (wrapper-depthoid test-layout) 2) 2) (- instance-pointer-lowtag)))) (inst ldr this-id (@ x offset)) ;; 8-bit IDs are permanently assigned, so no fixup ever needed for those. @@ -94,8 +92,8 @@ (:generator 6 (load-type result object (- other-pointer-lowtag)))) -(define-vop (fun-subtype) - (:translate fun-subtype) +(define-vop () + (:translate %fun-pointer-widetag) (:policy :fast-safe) (:args (function :scs (descriptor-reg))) (:results (result :scs (unsigned-reg))) @@ -116,10 +114,9 @@ (define-vop (set-header-data) (:translate set-header-data) (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) + (:args (x :scs (descriptor-reg)) (data :scs (any-reg immediate))) (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) t1) (:generator 6 (load-type t1 x (- other-pointer-lowtag)) @@ -132,8 +129,7 @@ ;; See SYS:SRC;COMPILER;ARM;MOVE.LISP for a partial fix... And ;; maybe it should be promoted to an instruction-macro? (inst orr t1 t1 (ash (tn-value data) n-widetag-bits)))) - (storew t1 x 0 other-pointer-lowtag) - (move res x))) + (storew t1 x 0 other-pointer-lowtag))) (define-vop (pointer-hash) @@ -220,9 +216,9 @@ (inst sub ndescr ndescr (- other-pointer-lowtag fun-pointer-lowtag)) (inst add func code ndescr))) ;;; -(define-vop (symbol-info-vector) +(define-vop (symbol-dbinfo) (:policy :fast-safe) - (:translate symbol-info-vector) + (:translate symbol-dbinfo) (:args (x :scs (descriptor-reg))) (:results (res :scs (descriptor-reg))) (:temporary (:sc unsigned-reg) temp) @@ -232,19 +228,6 @@ (inst and temp res lowtag-mask) (inst cmp temp list-pointer-lowtag) (loadw res res cons-cdr-slot list-pointer-lowtag :eq))) - -(define-vop (symbol-plist) - (:policy :fast-safe) - (:translate symbol-plist) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x) - ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist. - (loadw res res cons-car-slot list-pointer-lowtag) - (inst tst res fixnum-tag-mask) - (inst mov :eq res null-tn))) ;;;; other miscellaneous VOPs @@ -273,3 +256,11 @@ (:translate spin-loop-hint) (:policy :fast-safe) (:generator 0)) + +(define-vop (sb-c::mark-covered) + (:info x) + (:temporary (:sc unsigned-reg) tmp) + (:generator 4 + ;; Can't compute code-tn-relative index until the boxed header length + ;; is known. Some vops emit new boxed words via EMIT-CONSTANT. + (inst store-coverage-mark x tmp))) diff -Nru sbcl-2.1.1/src/compiler/arm/target-insts.lisp sbcl-2.1.11/src/compiler/arm/target-insts.lisp --- sbcl-2.1.1/src/compiler/arm/target-insts.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm/target-insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -46,7 +46,7 @@ (fixnum value) (ignore dstate)) (unless (= value 14) ;; Don't print :al - (princ (aref sb-vm::+condition-name-vec+ value) stream))) + (princ (aref +condition-name-vec+ value) stream))) (defun print-reg (value stream dstate) (declare (type stream stream) diff -Nru sbcl-2.1.1/src/compiler/arm64/alloc.lisp sbcl-2.1.11/src/compiler/arm64/alloc.lisp --- sbcl-2.1.1/src/compiler/arm64/alloc.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/alloc.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,62 +11,65 @@ (in-package "SB-VM") -(define-vop (list-or-list*) - (:args (things :more t :scs (control-stack))) +(define-vop (list) + (:args (things :more t :scs (descriptor-reg any-reg control-stack constant immediate))) (:temporary (:scs (descriptor-reg)) ptr) (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) res) (:temporary (:sc non-descriptor-reg) pa-flag temp) (:temporary (:scs (interior-reg)) lip) - (:info num) + (:info star cons-cells) (:results (result :scs (descriptor-reg))) - (:variant-vars star) - (:policy :fast-safe) (:node-var node) + (:vop-var vop) (:generator 0 - (cond ((zerop num) - (move result null-tn)) - ((and star (= num 1)) - (move result (tn-ref-tn things))) - (t - (macrolet - ((maybe-load (tn) + (let ((alloc (* (pad-data-block cons-size) cons-cells)) + (dx (node-stack-allocate-p node)) + (prev-constant)) + (macrolet ((maybe-load (tn) (once-only ((tn tn)) `(sc-case ,tn ((any-reg descriptor-reg) ,tn) + ((immediate constant) + (cond ((eql (tn-value ,tn) 0) + zr-tn) + ((or (eql prev-constant (tn-value ,tn)) + (progn + (setf prev-constant (tn-value ,tn)) + nil)) + temp) + ((sc-is ,tn constant) + (load-constant vop ,tn temp) + temp) + (t + (load-immediate vop ,tn temp) + temp))) (control-stack + (setf prev-constant nil) (load-stack-tn temp ,tn) temp))))) - (let* ((cons-cells (if star (1- num) num)) - (alloc (* (pad-data-block cons-size) cons-cells))) - (pseudo-atomic (pa-flag :sync nil) - (allocation 'list alloc list-pointer-lowtag res - :flag-tn pa-flag - :stack-allocate-p (node-stack-allocate-p node) - :lip lip) - (move ptr res) - (dotimes (i (1- cons-cells)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-lowtag) - (setf things (tn-ref-across things)) - (inst add ptr ptr (pad-data-block cons-size)) - (storew ptr ptr - (- cons-cdr-slot cons-size) - list-pointer-lowtag)) - (storew (maybe-load (tn-ref-tn things)) ptr - cons-car-slot list-pointer-lowtag) - (storew (if star - (maybe-load (tn-ref-tn (tn-ref-across things))) - null-tn) - ptr cons-cdr-slot list-pointer-lowtag)) - (move result res))))))) - -(define-vop (list list-or-list*) - (:variant nil)) - -(define-vop (list* list-or-list*) - (:variant t)) + (pseudo-atomic (pa-flag :sync nil :elide-if dx) + (allocation 'list alloc list-pointer-lowtag res + :flag-tn pa-flag + :stack-allocate-p dx + :lip lip) + (move ptr res) + (dotimes (i (1- cons-cells)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (setf things (tn-ref-across things)) + (inst add ptr ptr (pad-data-block cons-size)) + (storew ptr ptr + (- cons-cdr-slot cons-size) + list-pointer-lowtag)) + (storew (maybe-load (tn-ref-tn things)) ptr + cons-car-slot list-pointer-lowtag) + (storew (if star + (maybe-load (tn-ref-tn (tn-ref-across things))) + null-tn) + ptr cons-cdr-slot list-pointer-lowtag)) + (move result res))))) ;;;; Special purpose inline allocators. @@ -103,8 +106,7 @@ (logior (ash (1- size) n-widetag-bits) closure-widetag)) - (storew pa-flag result 0 fun-pointer-lowtag) - (storew function result closure-fun-slot fun-pointer-lowtag))))) + (storew-pair pa-flag 0 function closure-fun-slot tmp-tn))))) ;;; The compiler likes to be able to directly make value cells. ;;; @@ -117,8 +119,9 @@ (:generator 10 (with-fixed-allocation (result pa-flag value-cell-widetag value-cell-size :stack-allocate-p stack-allocate-p - :lip lip) - (storew value result value-cell-value-slot other-pointer-lowtag)))) + :lip lip + :store-type-code nil) + (storew-pair pa-flag 0 value value-cell-value-slot tmp-tn)))) ;;;; Automatic allocators for primitive objects. diff -Nru sbcl-2.1.1/src/compiler/arm64/arith.lisp sbcl-2.1.11/src/compiler/arm64/arith.lisp --- sbcl-2.1.1/src/compiler/arm64/arith.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/arith.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -48,7 +48,7 @@ (inst neg res x))) (define-vop (fast-negate/unsigned signed-unop) - (:args (x :scs (unsigned-reg) :target res)) + (:args (x :scs (unsigned-reg))) (:arg-types unsigned-num) (:translate %negate) (:generator 3 @@ -61,6 +61,21 @@ (:generator 3 (inst neg res x))) +(define-modular-fun %negate-mod64 (x) %negate :untagged nil 64) +(define-vop (%negate-mod64) + (:translate %negate-mod64) + (:policy :fast-safe) + (:args (x :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:results (r :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 3 + (inst neg r x))) + +(define-modular-fun %negate-modfx (x) %negate :tagged t #.n-fixnum-bits) +(define-vop (%negate-modfx fast-negate/fixnum) + (:translate %negate-modfx)) + (define-vop (fast-lognot/fixnum fixnum-unop) (:args (x :scs (any-reg))) (:arg-types tagged-num) @@ -79,45 +94,45 @@ ;;; Assume that any constant operand is the second arg... (define-vop (fast-fixnum-binop fast-safe-arith-op) - (:args (x :target r :scs (any-reg)) - (y :target r :scs (any-reg))) + (:args (x :scs (any-reg)) + (y :scs (any-reg))) (:arg-types tagged-num tagged-num) (:results (r :scs (any-reg))) (:result-types tagged-num) (:note "inline fixnum arithmetic")) (define-vop (fast-unsigned-binop fast-safe-arith-op) - (:args (x :target r :scs (unsigned-reg)) - (y :target r :scs (unsigned-reg))) + (:args (x :scs (unsigned-reg)) + (y :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num) (:note "inline (unsigned-byte 64) arithmetic")) (define-vop (fast-signed-binop fast-safe-arith-op) - (:args (x :target r :scs (signed-reg)) - (y :target r :scs (signed-reg))) + (:args (x :scs (signed-reg)) + (y :scs (signed-reg))) (:arg-types signed-num signed-num) (:results (r :scs (signed-reg))) (:result-types signed-num) (:note "inline (signed-byte 64) arithmetic")) (define-vop (fast-fixnum-binop-c fast-safe-arith-op) - (:args (x :target r :scs (any-reg))) + (:args (x :scs (any-reg))) (:info y) (:results (r :scs (any-reg))) (:result-types tagged-num) (:note "inline fixnum arithmetic")) (define-vop (fast-unsigned-binop-c fast-safe-arith-op) - (:args (x :target r :scs (unsigned-reg))) + (:args (x :scs (unsigned-reg))) (:info y) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num) (:note "inline (unsigned-byte 64) arithmetic")) (define-vop (fast-signed-binop-c fast-safe-arith-op) - (:args (x :target r :scs (signed-reg))) + (:args (x :scs (signed-reg))) (:info y) (:results (r :scs (signed-reg))) (:result-types signed-num) @@ -220,7 +235,7 @@ (define-vop (fast-logior-unsigned-signed=>signed fast-safe-arith-op) (:args (x :scs (unsigned-reg)) - (y :target r :scs (signed-reg))) + (y :scs (signed-reg))) (:arg-types unsigned-num signed-num) (:results (r :scs (signed-reg) :from (:argument 1))) (:result-types signed-num) @@ -230,7 +245,7 @@ (inst orr r x y))) (define-vop (fast-logior-signed-unsigned=>signed fast-safe-arith-op) - (:args (x :target r :scs (signed-reg)) + (:args (x :scs (signed-reg)) (y :scs (unsigned-reg))) (:arg-types signed-num unsigned-num) (:results (r :scs (signed-reg) :from (:argument 0))) @@ -244,7 +259,7 @@ (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) (:args (x :scs (signed-reg)) ;; one operand needs to be untagged - (y :target r :scs (any-reg))) + (y :scs (any-reg))) (:translate *) (:generator 2 (inst mul r x y))) @@ -314,11 +329,25 @@ (inst eor r r (lognot fixnum-tag-mask)))) (define-vop (fast-logand/signed-unsigned=>unsigned fast-logand/unsigned=>unsigned) - (:args (x :scs (signed-reg) :target r) - (y :scs (unsigned-reg) :target r)) + (:args (x :scs (signed-reg)) + (y :scs (unsigned-reg))) (:arg-types signed-num unsigned-num) (:translate logand)) +(defun logical-immediate-or-word-mask (x) + (and (integerp x) + (or (encode-logical-immediate x) + (= x most-positive-word)))) + +(define-vop (fast-logand-c/signed-unsigned=>unsigned fast-logand-c/unsigned=>unsigned) + (:args (x :scs (signed-reg))) + (:arg-types signed-num (:constant (satisfies logical-immediate-or-word-mask))) + (:translate logand) + (:generator 2 + (if (= y most-positive-word) + (move r x) + (inst and r x y)))) + (define-source-transform logeqv (&rest args) (if (oddp (length args)) `(logxor ,@args) @@ -330,24 +359,10 @@ ;;; Shifting -(define-vop (fast-ash-left-c/fixnum=>fixnum) - (:translate ash) - (:policy :fast-safe) - (:args (number :scs (any-reg) :target result)) - (:info amount) - (:arg-types tagged-num (:constant unsigned-byte)) - (:results (result :scs (any-reg))) - (:result-types tagged-num) - (:note "inline ASH") - (:generator 1 - (if (< amount 64) - (inst lsl result number amount) - (inst mov result 0)))) - (define-vop (fast-ash-right-c/fixnum=>fixnum) (:translate ash) (:policy :fast-safe) - (:args (number :scs (any-reg) :target result)) + (:args (number :scs (any-reg))) (:info amount) (:arg-types tagged-num (:constant (integer * -1))) (:results (result :scs (any-reg))) @@ -361,7 +376,7 @@ (define-vop (fast-ash-c/unsigned=>unsigned) (:translate ash) (:policy :fast-safe) - (:args (number :scs (unsigned-reg) :target result)) + (:args (number :scs (unsigned-reg))) (:info amount) (:arg-types unsigned-num (:constant integer)) (:results (result :scs (unsigned-reg))) @@ -378,7 +393,7 @@ (define-vop (fast-ash-c/signed=>signed) (:translate ash) (:policy :fast-safe) - (:args (number :scs (signed-reg) :target result)) + (:args (number :scs (signed-reg))) (:info amount) (:arg-types signed-num (:constant integer)) (:results (result :scs (signed-reg))) @@ -401,27 +416,86 @@ (:results (result)) (:policy :fast-safe) (:temporary (:sc non-descriptor-reg) temp) + (:args-var args) (:variant-vars variant) (:generator 5 (inst subs temp amount zr-tn) (inst b :ge LEFT) (inst neg temp temp) - (inst cmp temp n-word-bits) - ;; Only the first 6 bits count for shifts. - ;; This sets all bits to 1 if AMOUNT is larger than 63, - ;; cutting the amount to 63. - (inst csinv temp temp zr-tn :lt) - DO - (ecase variant - (:signed (inst asr result number temp)) - (:unsigned (inst lsr result number temp))) + (cond ((csubtypep (tn-ref-type (tn-ref-across args)) + (specifier-type `(integer -63 *))) + (ecase variant + (:signed (inst asr result number temp)) + (:unsigned (inst lsr result number temp)))) + (t + (inst cmp temp n-word-bits) + (ecase variant + (:signed + ;; Only the first 6 bits count for shifts. + ;; This sets all bits to 1 if AMOUNT is larger than 63, + ;; cutting the amount to 63. + (inst csinv temp temp zr-tn :lt) + (inst asr result number temp)) + (:unsigned + (inst csel result number zr-tn :lt) + (inst lsr result result temp))))) + (inst b END) LEFT - (inst cmp temp n-word-bits) - (inst csel result number zr-tn :lt) - (inst lsl result result temp) + (cond ((csubtypep (tn-ref-type (tn-ref-across args)) + (specifier-type `(integer * 63))) + (inst lsl result number temp)) + (t + (inst cmp temp n-word-bits) + (inst csel result number zr-tn :lt) + (inst lsl result result temp))) END)) +(define-vop (fast-ash-modfx/signed/unsigned=>fixnum) + (:note "inline ASH") + (:translate ash-modfx) + (:args (number :scs (signed-reg unsigned-reg) :to :save) + (amount :scs (signed-reg) :to :save :target temp)) + (:arg-types (:or signed-num unsigned-num) signed-num) + (:results (result :scs (any-reg))) + (:args-var args) + (:result-types tagged-num) + (:policy :fast-safe) + (:temporary (:sc non-descriptor-reg) temp temp-result) + (:generator 5 + (inst subs temp amount zr-tn) + (inst b :ge LEFT) + (inst neg temp temp) + (cond ((csubtypep (tn-ref-type (tn-ref-across args)) + (specifier-type `(integer -63 *))) + (sc-case number + (signed-reg (inst asr temp-result number temp)) + (unsigned-reg (inst lsr temp-result number temp)))) + (t + (inst cmp temp n-word-bits) + (sc-case number + (signed-reg + ;; Only the first 6 bits count for shifts. + ;; This sets all bits to 1 if AMOUNT is larger than 63, + ;; cutting the amount to 63. + (inst csinv temp temp zr-tn :lt) + (inst asr temp-result number temp)) + (unsigned-reg + (inst csel temp-result number zr-tn :lt) + (inst lsr temp-result temp-result temp))))) + + (inst b END) + LEFT + (cond ((csubtypep (tn-ref-type (tn-ref-across args)) + (specifier-type `(integer * 63))) + (inst lsl temp-result number temp)) + (t + (inst cmp temp n-word-bits) + (inst csel temp-result number zr-tn :lt) + (inst lsl temp-result temp-result temp))) + END + (inst lsl result temp-result n-fixnum-tag-bits))) + (define-vop (fast-ash/signed=>signed fast-ash/signed/unsigned) (:args (number :scs (signed-reg) :to :save) (amount :scs (signed-reg) :to :save :target temp)) @@ -440,39 +514,56 @@ (:translate ash) (:variant :unsigned)) -(macrolet ((def (name sc-type type result-type cost) - `(define-vop (,name) - (:note "inline ASH") - (:translate ash) - (:args (number :scs (,sc-type)) - (amount :scs (signed-reg unsigned-reg))) - ;; For modular variants - (:variant-vars cut) - (:arg-types ,type positive-fixnum) - (:results (result :scs (,result-type))) - (:result-types ,type) - (:policy :fast-safe) - (:generator ,cost - (cond (cut - (inst cmp amount n-word-bits) - (cond ((location= amount result) - (inst csel tmp-tn number zr-tn :lt) - (inst lsl result tmp-tn amount)) - (t - (inst csel result number zr-tn :lt) - (inst lsl result result amount)))) - (t - (inst lsl result number amount))))))) +(macrolet ((def (name name-c sc-type type result-type cost) + `(progn + (define-vop (,name) + (:note "inline ASH") + (:translate ash) + (:args (number :scs (,sc-type)) + (amount :scs (signed-reg unsigned-reg))) + ;; For modular variants + (:variant-vars cut) + (:arg-types ,type positive-fixnum) + (:args-var args) + (:results (result :scs (,result-type))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,cost + (cond ((and cut + (not (csubtypep (tn-ref-type (tn-ref-across args)) ;; amount + (specifier-type `(mod ,n-word-bits))))) + (inst cmp amount n-word-bits) + (cond ((location= amount result) + (inst csel tmp-tn number zr-tn :lt) + (inst lsl result tmp-tn amount)) + (t + (inst csel result number zr-tn :lt) + (inst lsl result result amount)))) + (t + (inst lsl result number amount))))) + (define-vop (,name-c) + (:note "inline ASH") + (:translate ash) + (:args (number :scs (,sc-type))) + (:info amount) + (:arg-types ,type (:constant unsigned-byte)) + (:results (result :scs (,result-type))) + (:result-types ,type) + (:policy :fast-safe) + (:generator ,(1- cost) + (if (< amount 64) + (inst lsl result number amount) + (inst mov result 0))))))) ;; FIXME: There's the opportunity for a sneaky optimization here, I ;; think: a FAST-ASH-LEFT-C/FIXNUM=>SIGNED vop. -- CSR, 2003-09-03 - (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2) - (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3) - (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3)) + (def fast-ash-left/fixnum=>fixnum fast-ash-left-c/fixnum=>fixnum any-reg tagged-num any-reg 2) + (def fast-ash-left/signed=>signed fast-ash-left-c/signed=>signed signed-reg signed-num signed-reg 3) + (def fast-ash-left/unsigned=>unsigned fast-ash-left-c/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3)) (define-vop (fast-%ash/right/unsigned) (:translate %ash/right) (:policy :fast-safe) - (:args (number :scs (unsigned-reg) :target result) + (:args (number :scs (unsigned-reg)) (amount :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:results (result :scs (unsigned-reg) :from (:argument 0))) @@ -483,7 +574,7 @@ (define-vop (fast-%ash/right/signed) (:translate %ash/right) (:policy :fast-safe) - (:args (number :scs (signed-reg) :target result) + (:args (number :scs (signed-reg)) (amount :scs (unsigned-reg))) (:arg-types signed-num unsigned-num) (:results (result :scs (signed-reg) :from (:argument 0))) @@ -494,7 +585,7 @@ (define-vop (fast-%ash/right/fixnum) (:translate %ash/right) (:policy :fast-safe) - (:args (number :scs (any-reg) :target result) + (:args (number :scs (any-reg)) (amount :scs (unsigned-reg) :target temp)) (:arg-types tagged-num unsigned-num) (:results (result :scs (any-reg) :from (:argument 0))) @@ -528,9 +619,27 @@ (:translate ash-left-mod64)) (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned + fast-ash-left-c/unsigned=>unsigned) + (:translate ash-left-mod64)) + +(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned fast-ash-c/unsigned=>unsigned) (:translate ash-left-mod64)) +(define-vop (fast-ash-modfx/signed=>signed + fast-ash/signed=>signed) + (:translate ash-modfx)) + +(define-vop (fast-ash-mod64/signed=>unsigned + fast-ash/signed=>signed) + (:results (result :scs (unsigned-reg))) + (:result-types unsigned-num) + (:translate ash-mod64)) + +(define-vop (fast-ash-mod64/unsigned=>unsigned + fast-ash/unsigned=>unsigned) + (:translate ash-mod64)) + ;;; Only the lower 6 bits of the shift amount are significant. (macrolet ((define (translate operation) `(define-vop () @@ -540,12 +649,10 @@ (:args (num :scs (unsigned-reg)) (amount :scs (signed-reg))) (:arg-types unsigned-num tagged-num) - (:temporary (:sc signed-reg) temp) (:results (r :scs (unsigned-reg))) (:result-types unsigned-num) (:generator 1 - (inst and temp amount #b111111) - (inst ,operation r num temp))))) + (inst ,operation r num amount))))) (define shift-towards-start lsr) (define shift-towards-end lsl)) @@ -584,30 +691,36 @@ (:translate logcount) (:note "inline (unsigned-byte 64) logcount") (:policy :fast-safe) - (:args (arg :scs (unsigned-reg))) - (:arg-types unsigned-num) + (:args (arg :scs (unsigned-reg any-reg))) + (:arg-types (:or unsigned-num positive-fixnum)) (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:temporary (:scs (double-reg)) v) (:variant-vars signed) - (:generator 30 - (when signed - (inst cmp arg 0) - (inst csinv res arg arg :ge) - (setf arg res)) - (inst fmov v arg) - (inst cnt v v :8b) - ;; GCC uses (inst addv v :b v :8b) - ;; but clang uses: - (inst uaddlv v :h v :8b) - (inst umov res v 0 :b))) + (:generator 29 + (when signed + (sc-case arg + (any-reg + ;; Don't invert the tag bit + (inst asr res arg n-fixnum-tag-bits) + (setf arg res)) + (t)) + ;; Invert when negative + (inst eor res arg (asr arg 63)) + (setf arg res)) + (inst fmov v arg) + (inst cnt v v :8b) + ;; GCC uses (inst addv v :b v :8b) + ;; but clang uses: + (inst uaddlv v :h v :8b) + (inst fmov res v))) (define-vop (signed-byte-64-count unsigned-byte-64-count) (:note "inline (signed-byte 64) logcount") - (:args (arg :scs (signed-reg))) - (:arg-types signed-num) + (:args (arg :scs (signed-reg any-reg))) + (:arg-types (:or signed-num fixnum)) (:variant t) - (:variant-cost 29)) + (:variant-cost 30)) (defknown %%ldb (integer unsigned-byte unsigned-byte) unsigned-byte (movable foldable flushable always-translatable)) @@ -619,6 +732,14 @@ (defun %%ldb (integer size posn) (%ldb size posn integer)) +(deftransform %%ldb ((integer size posn) (unsigned-byte t (constant-arg (integer #.n-word-bits))) * + :important nil) + 0) + +(deftransform %%ldb ((integer size posn) ((integer * -1) t (constant-arg (integer #.n-word-bits))) * + :important nil) + 1) + (defun %%dpb (newbyte size posn integer) (%dpb newbyte size posn integer)) @@ -632,7 +753,15 @@ (:result-types unsigned-num) (:policy :fast-safe) (:generator 2 - (inst ubfm res x (1+ posn) (+ posn size)))) + (cond ((<= (+ posn size) n-fixnum-bits) + (inst ubfm res x (1+ posn) (+ posn size))) + ((= size 1) + (inst lsr res x n-fixnum-bits)) + (t + ;; Can't constrain two constant args to avoid this VOP and + ;; go to the signed variant, so do it manually. + (inst asr res x (1+ posn)) + (inst and res res (ash most-positive-word (- size sb-vm:n-word-bits))))))) (define-vop (ldb-c) (:translate %%ldb) @@ -644,7 +773,10 @@ (:result-types unsigned-num) (:policy :fast-safe) (:generator 3 - (inst ubfm res x posn (+ posn size -1)))) + (if (and (>= (+ posn size) n-word-bits) + (= size 1)) + (inst lsr res x (1- n-word-bits)) + (inst ubfm res x posn (+ posn size -1))))) (define-vop (dpb-c/fixnum) (:translate %%dpb) @@ -709,7 +841,7 @@ (defmacro define-mod-binop ((name prototype) function) `(define-vop (,name ,prototype) - (:args (x :target r :scs (unsigned-reg signed-reg)) + (:args (x :scs (unsigned-reg signed-reg)) (y :scs (unsigned-reg signed-reg))) (:arg-types untagged-num untagged-num) (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0))) @@ -718,7 +850,7 @@ (defmacro define-mod-binop-c ((name prototype) function) `(define-vop (,name ,prototype) - (:args (x :target r :scs (unsigned-reg signed-reg))) + (:args (x :scs (unsigned-reg signed-reg))) (:info y) (:arg-types untagged-num (:constant (satisfies add-sub-immediate-p))) (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0))) @@ -739,8 +871,7 @@ (vopfxcf (symbolicate "FAST-" name "-MODFX-C/FIXNUM=>FIXNUM"))) `(progn (define-modular-fun ,fun64 (x y) ,name :untagged nil 64) - (define-modular-fun ,funfx (x y) ,name :tagged t - #.(- n-word-bits n-fixnum-tag-bits)) + (define-modular-fun ,funfx (x y) ,name :tagged t ,n-fixnum-bits) (define-mod-binop (,vop64u ,vopu) ,fun64) (define-vop (,vop64f ,vopf) (:translate ,fun64)) (define-vop (,vopfxf ,vopf) (:translate ,funfx)) @@ -892,7 +1023,7 @@ /unsigned -c/unsigned) for cost in '(4 3 6 5 6 5) for arg-types in '(nil - (fixnum + (tagged-num (:constant (satisfies fixnum-encode-logical-immediate))) nil @@ -952,7 +1083,7 @@ (define-vop (mask-signed-field-word/c) (:translate sb-c::mask-signed-field) (:policy :fast-safe) - (:args (x :scs (signed-reg unsigned-reg) :target r)) + (:args (x :scs (signed-reg unsigned-reg))) (:arg-types (:constant (integer 0 64)) untagged-num) (:results (r :scs (signed-reg))) (:result-types signed-num) @@ -967,7 +1098,7 @@ (define-vop (mask-signed-field-bignum/c) (:translate sb-c::mask-signed-field) (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target r)) + (:args (x :scs (descriptor-reg))) (:arg-types (:constant (integer 0 64)) bignum) (:results (r :scs (signed-reg))) (:result-types signed-num) @@ -1126,7 +1257,7 @@ (define-vop (mulhi) (:translate %multiply-high) (:policy :fast-safe) - (:args (x :scs (unsigned-reg) :target hi) + (:args (x :scs (unsigned-reg)) (y :scs (unsigned-reg))) (:arg-types unsigned-num unsigned-num) (:results (hi :scs (unsigned-reg))) @@ -1137,7 +1268,7 @@ (define-vop (mulhi/fx) (:translate %multiply-high) (:policy :fast-safe) - (:args (x :scs (any-reg) :target hi) + (:args (x :scs (any-reg)) (y :scs (unsigned-reg))) (:arg-types positive-fixnum unsigned-num) (:temporary (:sc unsigned-reg) temp) @@ -1187,7 +1318,7 @@ (define-vop (signify-digit) (:translate sb-bignum:%fixnum-digit-with-correct-sign) (:policy :fast-safe) - (:args (digit :scs (unsigned-reg) :target res)) + (:args (digit :scs (unsigned-reg))) (:arg-types unsigned-num) (:results (res :scs (any-reg signed-reg))) (:result-types signed-num) diff -Nru sbcl-2.1.1/src/compiler/arm64/array.lisp sbcl-2.1.11/src/compiler/arm64/array.lisp --- sbcl-2.1.1/src/compiler/arm64/array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -37,7 +37,7 @@ ;; See ENCODE-ARRAY-RANK. (inst sub ndescr rank (fixnumize 1)) (inst and ndescr ndescr (fixnumize array-rank-mask)) - (inst orr ndescr type (lsl ndescr array-rank-byte-pos)) + (inst orr ndescr type (lsl ndescr array-rank-position)) (inst lsr ndescr ndescr n-fixnum-tag-bits) ;; And store the header value. (storew ndescr header 0 other-pointer-lowtag)) @@ -59,10 +59,44 @@ (:results (res :scs (unsigned-reg))) (:result-types positive-fixnum) (:generator 6 - (inst ldrb res (@ x #+little-endian (- 2 other-pointer-lowtag) - #+big-endian (- 5 other-pointer-lowtag))) - (inst add res res 1) - (inst and res res array-rank-mask))) + (inst ldrsb res (@ x (- (/ array-rank-position n-word-bytes) + other-pointer-lowtag))) + (inst add res res 1))) + +(define-vop () + (:translate %array-rank=) + (:policy :fast-safe) + (:args (array :scs (descriptor-reg))) + (:temporary (:scs (unsigned-reg)) x) + (:info rank) + (:arg-types * (:constant t)) + (:conditional :eq) + (:generator 2 + (inst ldrb x (@ array (- (/ array-rank-position n-word-bytes) + other-pointer-lowtag))) + (inst cmp x (add-sub-immediate (encode-array-rank rank))))) + +(define-vop (simple-array-header-of-rank-p type-predicate) + (:translate sb-c::simple-array-header-of-rank-p) + (:policy :fast-safe) + (:info target not-p rank) + (:arg-types * (:constant t)) + (:generator 2 + (unless (other-pointer-tn-ref-p args) + (%test-lowtag value temp (if not-p + target + drop-through) + t other-pointer-lowtag)) + (inst ldrh temp (@ value (- other-pointer-lowtag))) + (inst cmp temp (add-sub-immediate + (dpb (encode-array-rank rank) + (byte 8 array-rank-position) + simple-array-widetag))) + (inst b (if not-p + :ne + :eq) + target) + drop-through)) ;;;; Bounds checking routine. (define-vop (check-bound) @@ -118,6 +152,8 @@ (cond ((integerp bound) (inst cmp index bound) (inst b :hs error)) + ((eql index 0) + (inst cbz bound error)) (t (inst cmp bound index) (inst b :ls error)))))))) @@ -226,12 +262,12 @@ (:translate data-vector-ref) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg))) + (index :scs (unsigned-reg) :to :save)) (:arg-types ,type positive-fixnum) - (:results (value :scs (any-reg))) + (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) (:temporary (:scs (interior-reg)) lip) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result) + (:temporary (:scs (non-descriptor-reg)) temp) (:generator 20 ;; Compute the offset for the word we're interested in. (inst lsr temp index ,bit-shift) @@ -241,7 +277,9 @@ (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))) ;; Compute the position of the bitfield we need. - (inst and temp index ,(1- elements-per-word)) + ,(if (= bits 1) + `(setf temp index) + `(inst and temp index ,(1- elements-per-word))) ,@(when (eq *backend-byte-order* :big-endian) `((inst eor temp temp ,(1- elements-per-word)))) ,@(unless (= bits 1) @@ -249,9 +287,7 @@ ;; Shift the field we need to the low bits of RESULT. (inst lsr result result temp) ;; Mask out the field we're interested in. - (inst and result result ,(1- (ash 1 bits))) - ;; And fixnum-tag the result. - (inst lsl value result n-fixnum-tag-bits))) + (inst and result result ,(1- (ash 1 bits))))) (define-vop (,(symbolicate "DATA-VECTOR-REF/" type "-C")) (:note "inline array access") (:translate data-vector-ref) @@ -259,9 +295,8 @@ (:args (object :scs (descriptor-reg))) (:info index) (:arg-types ,type (:constant index)) - (:results (value :scs (any-reg))) + (:results (result :scs (unsigned-reg))) (:result-types positive-fixnum) - (:temporary (:scs (non-descriptor-reg) :to (:result 0)) result) (:generator 15 (multiple-value-bind (index bit) (floor index ,elements-per-word) (inst ldr result (@ object @@ -269,63 +304,121 @@ (+ (* index n-word-bytes) (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))) - (inst ubfm result result (* bit ,bits) (+ (* bit ,bits) (1- ,bits))) - (inst lsl value result n-fixnum-tag-bits)))) + (inst ubfm result result (* bit ,bits) (+ (* bit ,bits) (1- ,bits)))))) + (define-vop (,(symbolicate "DATA-VECTOR-SET/" type "-C")) + (:note "inline array store") + (:translate data-vector-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (value :scs (unsigned-reg) + :load-if (not (and (sc-is value immediate) + (memq (tn-value value) + '(0 ,(1- (ash 1 bits)))))))) + (:info index) + (:arg-types ,type (:constant index) positive-fixnum) + (:temporary (:scs (non-descriptor-reg)) old) + (:generator 20 + (multiple-value-bind (index bit) (floor index ,elements-per-word) + (inst ldr old (@ object + (load-store-offset + (+ (* index n-word-bytes) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag))))) + (cond ((not (sc-is value immediate)) + (inst bfm old value (mod (- n-word-bits (* bit ,bits)) n-word-bits) (1- ,bits))) + ((zerop (tn-value value)) + (inst and old old (lognot (ash (1- (ash 1 ,bits)) (* bit ,bits))))) + (t + (inst orr old old (ash (1- (ash 1 ,bits)) (* bit ,bits))))) + (inst str old (@ object + (load-store-offset + (+ (* index n-word-bytes) + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag)))))))) (define-vop (,(symbolicate "DATA-VECTOR-SET/" type)) (:note "inline array store") (:translate data-vector-set) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg) :target shift) - (value :scs (unsigned-reg immediate) :target result)) + (index :scs (unsigned-reg) + ,@(unless (= bits 1) + '(:target shift))) + (value :scs (unsigned-reg immediate))) (:arg-types ,type positive-fixnum positive-fixnum) - (:results (result :scs (unsigned-reg))) - (:result-types positive-fixnum) (:temporary (:scs (interior-reg)) lip) (:temporary (:scs (non-descriptor-reg)) temp old) - (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift) + ,@(unless (= bits 1) + '((:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift))) (:generator 25 - ;; Compute the offset for the word we're interested in. - (inst lsr temp index ,bit-shift) - ;; Load the word in question. - (inst add lip object (lsl temp word-shift)) - (inst ldr old (@ lip - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))) - ;; Compute the position of the bitfield we need. - (inst and shift index ,(1- elements-per-word)) - ,@(when (eq *backend-byte-order* :big-endian) - `((inst eor shift ,(1- elements-per-word)))) - ,@(unless (= bits 1) - `((inst lsl shift shift ,(1- (integer-length bits))))) - ;; Clear the target bitfield. - (unless (and (sc-is value immediate) - (= (tn-value value) ,(1- (ash 1 bits)))) - (inst mov temp ,(1- (ash 1 bits))) - (inst lsl temp temp shift) - (inst bic old old temp)) - ;; LOGIOR in the new value (shifted appropriatly). - (sc-case value - (immediate - (inst mov temp (logand (tn-value value) ,(1- (ash 1 bits))))) - (unsigned-reg - (inst and temp value ,(1- (ash 1 bits))))) - (inst lsl temp temp shift) - (inst orr old old temp) - ;; Write the altered word back to the array. - (inst str old (@ lip - (- (* vector-data-offset n-word-bytes) - other-pointer-lowtag))) - ;; And present the result properly. - (sc-case value - (immediate - (inst mov result (tn-value value))) - (unsigned-reg - (move result value))))))))) + (let ((shift ,(if (= bits 1) + 'index + 'shift))) + ;; Compute the offset for the word we're interested in. + (inst lsr temp index ,bit-shift) + ;; Load the word in question. + (inst add lip object (lsl temp word-shift)) + (inst ldr old (@ lip + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag))) + ;; Compute the position of the bitfield we need. + ,@(unless (= bits 1) + `((inst and shift index ,(1- elements-per-word)))) + ,@(when (eq *backend-byte-order* :big-endian) + `((inst eor shift ,(1- elements-per-word)))) + ,@(unless (= bits 1) + `((inst lsl shift shift ,(1- (integer-length bits))))) + ;; Clear the target bitfield. + (unless (and (sc-is value immediate) + (= (tn-value value) ,(1- (ash 1 bits)))) + (inst mov temp ,(1- (ash 1 bits))) + (inst lsl temp temp shift) + (inst bic old old temp)) + (unless (and (sc-is value immediate) + (= (tn-value value) 0)) + ;; LOGIOR in the new value (shifted appropriatly). + (sc-case value + (immediate + (inst mov temp (logand (tn-value value) ,(1- (ash 1 bits)))) + (inst lsl temp temp shift)) + (unsigned-reg + (inst lsl temp value shift))) + (inst orr old old temp)) + ;; Write the altered word back to the array. + (inst str old (@ lip + (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag)))))))))) (def-small-data-vector-frobs simple-bit-vector 1) (def-small-data-vector-frobs simple-array-unsigned-byte-2 2) (def-small-data-vector-frobs simple-array-unsigned-byte-4 4)) +(define-vop (data-vector-ref/simple-bit-vector-eq) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) (index :scs (unsigned-reg))) + (:arg-types simple-bit-vector positive-fixnum) + (:conditional :eq) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:scs (non-descriptor-reg)) temp x) + (:generator 20 + (inst lsr temp index 6) + (inst add lip object (lsl temp word-shift)) + (inst ldr x (@ lip (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))) + (inst lsr x x index) + (inst tst x 1))) + +(define-vop (data-vector-ref/simple-bit-vector-c-eq) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg))) + (:info index) + (:arg-types simple-bit-vector (:constant index)) + (:conditional :eq) + (:temporary (:scs (non-descriptor-reg)) x) + (:generator 15 + (multiple-value-bind (index bit) + (floor index 64) + (inst ldr x (@ object (load-store-offset (+ (* index n-word-bytes) + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag))))) + (inst tst x (ash 1 bit))))) + ;;; And the float variants. (define-vop (data-vector-ref/simple-array-single-float) (:note "inline array access") @@ -349,18 +442,14 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg)) - (value :scs (single-reg) :target result)) + (value :scs (single-reg))) (:arg-types simple-array-single-float positive-fixnum single-float) - (:results (result :scs (single-reg))) - (:result-types single-float) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) (:generator 5 (inst lsl offset index (1- (- word-shift n-fixnum-tag-bits))) (inst add offset offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) - (inst str value (@ object offset)) - (unless (location= result value) - (inst fmov result value)))) + (inst str value (@ object offset)))) (define-vop (data-vector-ref/simple-array-double-float) (:note "inline array access") @@ -384,18 +473,14 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg)) - (value :scs (double-reg) :target result)) + (value :scs (double-reg))) (:arg-types simple-array-double-float positive-fixnum double-float) - (:results (result :scs (double-reg))) - (:result-types double-float) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) (:generator 20 (inst lsl offset index (- word-shift n-fixnum-tag-bits)) (inst add offset offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) - (inst str value (@ object offset)) - (unless (location= result value) - (inst fmov result value)))) + (inst str value (@ object offset)))) ;;; Complex float arrays. @@ -421,19 +506,15 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to :result) (index :scs (any-reg)) - (value :scs (complex-single-reg) :target result)) + (value :scs (complex-single-reg))) (:arg-types simple-array-complex-single-float positive-fixnum complex-single-float) - (:results (result :scs (complex-single-reg))) - (:result-types complex-single-float) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) (:generator 5 (inst lsl offset index (- word-shift n-fixnum-tag-bits)) (inst add offset offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) - (inst str value (@ object offset)) - (unless (location= result value) - (inst fmov result value)))) + (inst str value (@ object offset)))) (define-vop (data-vector-ref/simple-array-complex-double-float) (:note "inline array access") @@ -457,19 +538,15 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to :result) (index :scs (any-reg)) - (value :scs (complex-double-reg) :target result)) + (value :scs (complex-double-reg))) (:arg-types simple-array-complex-double-float positive-fixnum complex-double-float) - (:results (result :scs (complex-double-reg))) - (:result-types complex-double-float) (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset) (:generator 5 (inst lsl offset index (1+ (- word-shift n-fixnum-tag-bits))) (inst add offset offset (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)) - (inst str value (@ object offset)) - (unless (location= result value) - (inst s-mov result value)))) + (inst str value (@ object offset)))) ;;; These vops are useful for accessing the bits of a vector irrespective of ;;; what type of vector it is. @@ -510,3 +587,22 @@ (inst stlxr tmp-tn sum lip) (inst cbnz tmp-tn LOOP) (inst dmb))) + +(define-vop (array-atomic-incf/word-v8.1) + (:translate %array-atomic-incf/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg) :target offset) + (diff :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:results (result :scs (unsigned-reg) :from :load)) + (:result-types unsigned-num) + (:temporary (:sc unsigned-reg) offset) + (:temporary (:sc interior-reg) lip) + (:guard (member :arm-v8.1 *backend-subfeatures*)) + (:generator 3 + (inst lsl offset index (- word-shift n-fixnum-tag-bits)) + (inst add offset offset (- (* vector-data-offset n-word-bytes) + other-pointer-lowtag)) + (inst add lip object offset) + (inst ldaddal diff result lip))) diff -Nru sbcl-2.1.1/src/compiler/arm64/call.lisp sbcl-2.1.11/src/compiler/arm64/call.lisp --- sbcl-2.1.1/src/compiler/arm64/call.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,51 +14,31 @@ (defconstant arg-count-sc (make-sc+offset immediate-arg-scn nargs-offset)) (defconstant closure-sc (make-sc+offset descriptor-reg-sc-number lexenv-offset)) -;;; Make a passing location TN for a local call return PC. If -;;; standard is true, then use the standard (full call) location, -;;; otherwise use any legal location. Even in the non-standard case, -;;; this may be restricted by a desire to use a subroutine call -;;; instruction. -(defun make-return-pc-passing-location (standard) - (declare (ignore standard)) - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset)) - (defconstant return-pc-passing-offset (make-sc+offset control-stack-sc-number lra-save-offset)) -;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a -;;; location to pass OLD-FP in. -;;; -;;; This is wired in both the standard and the local-call conventions, -;;; because we want to be able to assume it's always there. Besides, -;;; the ARM doesn't have enough registers to really make it profitable -;;; to pass it in a register. -(defun make-old-fp-passing-location () - (make-wired-tn *fixnum-primitive-type* control-stack-sc-number - ocfp-save-offset)) - (defconstant old-fp-passing-offset (make-sc+offset control-stack-sc-number ocfp-save-offset)) ;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current ;;; function. We treat these specially so that the debugger can find ;;; them at a known location. -(defun make-old-fp-save-location (env) +(defun make-old-fp-save-location () ;; Unlike the other backends, ARM function calling is designed to ;; pass OLD-FP within the stack frame rather than in a register. As ;; such, in order for lifetime analysis not to screw up, we need it ;; to be a stack TN wired to the save offset, not a normal TN with a ;; wired SAVE-TN. - (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type* - control-stack-arg-scn - ocfp-save-offset) - env)) -(defun make-return-pc-save-location (physenv) - (physenv-debug-live-tn - (make-wired-tn *backend-t-primitive-type* control-stack-sc-number - lra-save-offset) - physenv)) + (let ((tn (make-wired-tn *fixnum-primitive-type* + control-stack-arg-scn + ocfp-save-offset))) + (setf (tn-kind tn) :environment) + tn)) +(defun make-return-pc-save-location () + (let ((tn (make-wired-tn *backend-t-primitive-type* control-stack-sc-number + lra-save-offset))) + (setf (tn-kind tn) :environment) + tn)) ;;; Make a TN for the standard argument count passing location. We ;;; only need to make the standard location, since a count is never @@ -122,7 +102,7 @@ ;; Allocate function header. (inst simple-fun-header-word) (inst .skip (* (1- simple-fun-insts-offset) n-word-bytes)) - (inst compute-code code-tn lip start-lab))) + (inst str lip (@ cfp-tn (* lra-save-offset n-word-bytes))))) (define-vop (xep-setup-sp) (:vop-var vop) @@ -143,7 +123,7 @@ (move res csp-tn) (inst add csp-tn csp-tn (add-sub-immediate (* (max 1 (sb-allocated-size 'control-stack)) n-word-bytes))) - (when (ir2-physenv-number-stack-p callee) + (when (ir2-environment-number-stack-p callee) (inst sub nfp nsp-tn (add-sub-immediate (bytes-needed-for-non-descriptor-stack-frame))) (inst mov-sp nsp-tn nfp)))) @@ -151,18 +131,21 @@ ;;; Allocate a partial frame for passing stack arguments in a full call. Nargs ;;; is the number of arguments passed. If no stack arguments are passed, then ;;; we don't have to do anything. +;;; LR and CFP are always saved on the stack, but it's safe to have two words above CSP. (define-vop (allocate-full-call-frame) (:info nargs) (:results (res :scs (any-reg))) (:generator 2 - ;; Unlike most other backends, we store the "OCFP" at frame - ;; allocation time rather than at function-entry time, largely due - ;; to a lack of usable registers. - ;; Our minimum caller frame size is two words, one for the frame - ;; link and one for the LRA. - (move res csp-tn) - (inst add csp-tn csp-tn (add-sub-immediate (* (max 2 nargs) n-word-bytes))) - (storew cfp-tn res ocfp-save-offset))) + (if (<= nargs register-arg-count) + ;; Don't touch RES, the call vops would use CSP-TN in this case. + (storew cfp-tn csp-tn ocfp-save-offset) + (let ((size (add-sub-immediate (* nargs n-word-bytes)))) + (move res csp-tn) + (cond ((typep size '(signed-byte 9)) + (inst str cfp-tn (@ csp-tn size :post-index))) + (t + (inst add csp-tn csp-tn size) + (storew cfp-tn res ocfp-save-offset))))))) ;;; Emit code needed at the return-point from an unknown-values call ;;; for a fixed number of values. VALUES is the head of the TN-REF @@ -190,14 +173,15 @@ ;;; -- Reset SP. This must be done whenever other than 1 value is returned, ;;; regardless of the number of values desired. -(defun default-unknown-values (vop values nvals move-temp lip lra-label) +(defun default-unknown-values (vop values nvals move-temp node) (declare (type (or tn-ref null) values) (type unsigned-byte nvals) (type tn move-temp)) - (let ((expecting-values-on-stack (> nvals register-arg-count))) + (let* ((type (sb-c::node-derived-type node)) + (min-values (values-type-min-value-count type)) + (expecting-values-on-stack (> nvals register-arg-count))) (note-this-location vop (if (<= nvals 1) :single-value-return :unknown-return)) - (inst compute-code code-tn lip lra-label) ;; Pick off the single-value case first. (sb-assem:without-scheduling () @@ -209,13 +193,20 @@ (val (tn-ref-across values) (tn-ref-across val))) ((= i (min nvals register-arg-count))) (unless (eq (tn-kind (tn-ref-tn val)) :unused) - (inst csel (tn-ref-tn val) null-tn (tn-ref-tn val) :ne)))) + (cond + ((and min-values + (> min-values i))) + (t + (inst csel (tn-ref-tn val) null-tn (tn-ref-tn val) :ne)))))) ;; If we're not expecting values on the stack, all that ;; remains is to clear the stack frame (for the multiple- ;; value return case). - (unless expecting-values-on-stack - (inst csel csp-tn ocfp-tn csp-tn :eq)) + (unless (or expecting-values-on-stack + (type-single-value-p type)) + (if (values-type-may-be-single-value-p type) + (inst csel csp-tn ocfp-tn csp-tn :eq) + (inst mov csp-tn ocfp-tn))) ;; If we ARE expecting values on the stack, we need to ;; either move them to their result location or to set their @@ -225,9 +216,10 @@ ;; For the single-value return case, fake up NARGS and ;; OCFP so that we don't screw ourselves with the ;; defaulting and stack clearing logic. - (inst csel ocfp-tn csp-tn ocfp-tn :ne) - (inst mov tmp-tn (fixnumize 1)) - (inst csel nargs-tn tmp-tn nargs-tn :ne) + (unless (> min-values 1) + (inst csel ocfp-tn csp-tn ocfp-tn :ne) + (inst mov tmp-tn (fixnumize 1)) + (inst csel nargs-tn tmp-tn nargs-tn :ne)) ;; For each expected stack value... (do ((i register-arg-count (1+ i)) @@ -238,22 +230,64 @@ (tn-ref-across val))) ((null val)) (let ((tn (tn-ref-tn val))) - (if (eq (tn-kind tn) :unused) - (incf decrement (fixnumize 1)) - (assemble () - ;; ... Load it if there is a stack value available, or - ;; default it if there isn't. - (inst subs nargs-tn nargs-tn decrement) - (setf decrement (fixnumize 1)) - (inst b :lt NONE) - (loadw move-temp ocfp-tn i 0) - NONE - (sc-case tn - (control-stack - (inst csel move-temp null-tn move-temp :lt) - (store-stack-tn tn move-temp)) - (t - (inst csel tn null-tn move-temp :lt))))))) + (cond ((eq (tn-kind tn) :unused) + (incf decrement (fixnumize 1))) + ((< i min-values) + (incf decrement (fixnumize 1)) + (sc-case tn + (control-stack + (let* ((next (and (< (1+ i) min-values) + (tn-ref-across val))) + (next-tn (and next + (tn-ref-tn next)))) + (cond ((and next-tn + (not (sc-is next-tn control-stack)) + (neq (tn-kind next-tn) :unused) + (ldp-stp-offset-p (* i n-word-bytes) n-word-bits)) + (inst ldp move-temp next-tn + (@ ocfp-tn (* i n-word-bytes))) + (store-stack-tn tn move-temp) + (setf val next) + (incf i) + (incf decrement (fixnumize 1))) + (t + (loadw move-temp ocfp-tn i) + (store-stack-tn tn move-temp))))) + (t + (let* ((next (and (< (1+ i) min-values) + (tn-ref-across val))) + (next-tn (and next + (tn-ref-tn next)))) + (cond ((and next-tn + (neq (tn-kind next-tn) :unused) + (ldp-stp-offset-p (* i n-word-bytes) n-word-bits)) + (let ((stack (sc-is next-tn control-stack))) + (inst ldp tn (if stack + move-temp + next-tn) + (@ ocfp-tn (* i n-word-bytes))) + (when stack + (store-stack-tn next-tn move-temp))) + (setf val next) + (incf i) + (incf decrement (fixnumize 1))) + (t + (loadw tn ocfp-tn i))))))) + (t + (assemble () + ;; ... Load it if there is a stack value available, or + ;; default it if there isn't. + (inst subs nargs-tn nargs-tn decrement) + (setf decrement (fixnumize 1)) + (inst b :lt NONE) + (loadw move-temp ocfp-tn i) + NONE + (sc-case tn + (control-stack + (inst csel move-temp null-tn move-temp :lt) + (store-stack-tn tn move-temp)) + (t + (inst csel tn null-tn move-temp :lt)))))))) ;; Deallocate the callee stack frame. (move csp-tn ocfp-tn)))) (values)) @@ -276,14 +310,12 @@ ;;; Args and Nargs are TNs wired to the named locations. We must ;;; explicitly allocate these TNs, since their lifetimes overlap with the ;;; results Start and Count (also, it's nice to be able to target them). -(defun receive-unknown-values (args nargs start count lra-label lip) +(defun receive-unknown-values (args nargs start count) (declare (type tn args nargs start count)) (assemble () - (inst compute-code code-tn lip lra-label) (inst b :eq MULTIPLE) (move start csp-tn) - (inst add csp-tn csp-tn n-word-bytes) - (inst str (first *register-arg-tns*) (@ start)) + (inst str (first *register-arg-tns*) (@ csp-tn n-word-bytes :post-index)) (inst mov count (fixnumize 1)) (inst b DONE) MULTIPLE @@ -312,9 +344,12 @@ ;;; points, local-call entry points, and tail-call entry points. The default ;;; does nothing. (defun emit-block-header (start-label trampoline-label fall-thru-p alignp) - (declare (ignore fall-thru-p alignp)) + (declare (ignore alignp)) + (when (and fall-thru-p trampoline-label) + (inst b start-label)) (when trampoline-label - (emit-label trampoline-label)) + (emit-label trampoline-label) + (inst str lr-tn (@ cfp-tn (* lra-save-offset n-word-bytes)))) (emit-label start-label)) @@ -344,7 +379,7 @@ ;; NARGS is live. FP has been set up by the caller, SP is ;; protecting our stack arguments, but is otherwise not set up. NFP ;; is not yet set up. CODE and NULL are set up. SP and NFP must be - ;; correctly set up by the time we're done, and OCFP and R8 are + ;; correctly set up by the time we're done, and OCFP and R9 are ;; available for use as temporaries. If we were any more register ;; constrained, we'd be spilling registers manually (rather than ;; allowing PACK to do it for us). -- AJB, 2012-Oct-30 @@ -355,7 +390,7 @@ ;; live). (:temporary (:sc any-reg :offset ocfp-offset :to :eval) count) (:temporary (:sc any-reg :offset ocfp-offset :from :eval) dest) - (:temporary (:sc descriptor-reg :offset r8-offset) temp) + (:temporary (:sc descriptor-reg :offset r9-offset) temp) (:info fixed) (:generator 20 ;; We open up with a LET to obtain a TN for NFP. We'll call it @@ -368,8 +403,6 @@ :sc (sc-or-lose 'any-reg) :offset nfp-offset)) (delta (- (sb-allocated-size 'control-stack) fixed))) - ;; And we use ASSEMBLE here so that we get "implcit labels" - ;; rather than having to use GEN-LABEL and EMIT-LABEL. (assemble () ;; Compute the end of the fixed stack frame (start of the MORE ;; arg area) into RESULT. @@ -429,17 +462,20 @@ DO-REGS (when (< fixed register-arg-count) ;; Now we have to deposit any more args that showed up in registers. - (inst subs count nargs-tn (fixnumize fixed)) - (do ((i fixed (1+ i))) - ((>= i register-arg-count)) - ;; Don't deposit any more than there are. - (inst b :eq DONE) - (inst subs count count (fixnumize 1)) - ;; Store it into the space reserved to it, by displacement - ;; from the frame pointer. - (storew (nth i *register-arg-tns*) - cfp-tn (+ (sb-allocated-size 'control-stack) - (- i fixed))))) + (loop with i = fixed + for offset = (+ delta i) + do + (cond ((and (< (1+ i) register-arg-count) + (ldp-stp-offset-p (* offset n-word-bytes) n-word-bits)) + (inst stp + (nth i *register-arg-tns*) + (nth (1+ i) *register-arg-tns*) + (@ cfp-tn (* offset n-word-bytes))) + (incf i 2)) + (t + (storew (nth i *register-arg-tns*) cfp-tn offset) + (incf i))) + while (< i register-arg-count))) DONE ;; Now that we're done with the &MORE args, we can set up the @@ -472,6 +508,20 @@ (inst add temp context (lsl index (- word-shift n-fixnum-tag-bits))) (loadw value temp))))) +(define-vop () + (:translate sb-c::%more-keyword-pair) + (:policy :fast-safe) + (:args (context :scs (descriptor-reg)) + (index :scs (any-reg))) + (:arg-types * tagged-num) + (:temporary (:scs (any-reg)) temp) + (:results (keyword :scs (descriptor-reg any-reg)) + (value :scs (descriptor-reg any-reg))) + (:result-types * *) + (:generator 5 + (inst add temp context (lsl index (- word-shift n-fixnum-tag-bits))) + (inst ldp keyword value (@ temp)))) + (define-vop (more-arg-or-nil) (:policy :fast-safe) (:args (object :scs (descriptor-reg) :to (:result 1)) @@ -515,40 +565,39 @@ (move result null-tn) (inst cbz count DONE) - ;; We need to do this atomically. - (pseudo-atomic (pa-flag :sync nil) - ;; Allocate a cons (2 words) for each item. - (let* ((dx-p (node-stack-allocate-p node)) - (size (cond (dx-p - (lsl count (1+ (- word-shift n-fixnum-tag-bits)))) - (t - (inst lsl temp count (1+ (- word-shift n-fixnum-tag-bits))) - temp)))) - (allocation 'list size list-pointer-lowtag dst - :flag-tn pa-flag - :stack-allocate-p dx-p - :lip lip)) - (move result dst) - - (inst b ENTER) - - ;; Compute the next cons and store it in the current one. - LOOP - (inst add dst dst (* 2 n-word-bytes)) - (storew dst dst -1 list-pointer-lowtag) - - ;; Grab one value. - ENTER - (inst ldr temp (@ context n-word-bytes :post-index)) - - ;; Dec count, and if != zero, go back for more. - (inst subs count count (fixnumize 1)) - ;; Store the value into the car of the current cons. - (storew temp dst 0 list-pointer-lowtag) - (inst b :gt LOOP) + (let ((dx-p (node-stack-allocate-p node))) + (pseudo-atomic (pa-flag :sync nil :elide-if dx-p) + ;; Allocate a cons (2 words) for each item. + (let ((size (cond (dx-p + (lsl count (1+ (- word-shift n-fixnum-tag-bits)))) + (t + (inst lsl temp count (1+ (- word-shift n-fixnum-tag-bits))) + temp)))) + (allocation 'list size list-pointer-lowtag dst + :flag-tn pa-flag + :stack-allocate-p dx-p + :lip lip)) + (move result dst) + + (inst b ENTER) + + ;; Compute the next cons and store it in the current one. + LOOP + (inst add dst dst (* 2 n-word-bytes)) + (storew dst dst -1 list-pointer-lowtag) + + ;; Grab one value. + ENTER + (inst ldr temp (@ context n-word-bytes :post-index)) + + ;; Dec count, and if != zero, go back for more. + (inst subs count count (fixnumize 1)) + ;; Store the value into the car of the current cons. + (storew temp dst 0 list-pointer-lowtag) + (inst b :gt LOOP) - ;; NIL out the last cons. - (storew null-tn dst 1 list-pointer-lowtag)) + ;; NIL out the last cons. + (storew null-tn dst 1 list-pointer-lowtag))) DONE)) ;;; Return the location and size of the more arg glob created by @@ -633,26 +682,22 @@ (:move-args :local-call) (:info arg-locs callee target nvals) (:vop-var vop) + (:node-var node) (:temporary (:scs (descriptor-reg) :from (:eval 0)) move-temp) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) (:temporary (:sc any-reg :offset ocfp-offset :from (:eval 0)) ocfp) - (:temporary (:scs (interior-reg)) lip) (:ignore arg-locs args ocfp) (:generator 5 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra lip lip label) - (store-stack-tn (callee-return-pc-tn callee) lip) (note-this-location vop :call-site) - (inst b target) - (emit-return-pc label) - (default-unknown-values vop values nvals move-temp lip label) + (inst bl target) + (default-unknown-values vop values nvals move-temp node) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) @@ -674,10 +719,8 @@ (:ignore args save r0-temp) (:vop-var vop) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (interior-reg)) lip) (:generator 20 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (let ((callee-nfp (callee-nfp-tn callee))) @@ -685,13 +728,10 @@ (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra lip lip label) - (store-stack-tn (callee-return-pc-tn callee) lip) (note-this-location vop :call-site) - (inst b target) - (emit-return-pc label) + (inst bl target) (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count label lip) + (receive-unknown-values values-start nvals start count) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) @@ -714,21 +754,16 @@ (:ignore args res save) (:vop-var vop) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:scs (interior-reg)) lip) (:generator 5 - (let ((label (gen-label)) - (cur-nfp (current-nfp-tn vop))) + (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (let ((callee-nfp (callee-nfp-tn callee))) (when callee-nfp (maybe-load-stack-tn callee-nfp nfp))) (maybe-load-stack-tn cfp-tn fp) - (inst compute-lra lip lip label) - (store-stack-tn (callee-return-pc-tn callee) lip) (note-this-location vop :call-site) - (inst b target) - (emit-return-pc label) + (inst bl target) (note-this-location vop :known-return) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) @@ -742,10 +777,9 @@ ;;; MAYBE-LOAD-STACK-TN. (define-vop (known-return) (:args (old-fp :target old-fp-temp) - (return-pc :target return-pc-temp) + (return-pc) (vals :more t)) (:temporary (:sc any-reg :from (:argument 0)) old-fp-temp) - (:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp) (:temporary (:scs (interior-reg)) lip) (:move-args :known-return) (:info val-locs) @@ -753,14 +787,14 @@ (:vop-var vop) (:generator 6 (maybe-load-stack-tn old-fp-temp old-fp) - (maybe-load-stack-tn return-pc-temp return-pc) + (maybe-load-stack-tn lip return-pc) (move csp-tn cfp-tn) (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp (inst add nsp-tn cur-nfp (add-sub-immediate (bytes-needed-for-non-descriptor-stack-frame))))) (move cfp-tn old-fp-temp) - (lisp-return return-pc-temp lip :known))) + (lisp-return lip :known))) ;;;; Full call: ;;; @@ -801,6 +835,7 @@ ;;; In tail call with fixed arguments, the passing locations are passed as a ;;; more arg, but there is no new-FP, since the arguments have been set up in ;;; the current frame. +;(defvar fun-type :function) (defmacro define-full-call (name named return variable) (aver (not (and variable (eq return :tail)))) `(define-vop (,name @@ -811,11 +846,11 @@ '((new-fp :scs (any-reg) :to :eval))) ,@(case named - ((nil) - '((arg-fun :target lexenv))) - (:direct) - (t - '((name :target name-pass)))) + ((nil) + '((arg-fun :target lexenv))) + (:direct) + (t + '((name :target name-pass)))) ,@(when (eq return :tail) '((old-fp) @@ -832,26 +867,31 @@ '((:move-args :full-call))) (:vop-var vop) + (:node-var node) (:info ,@(unless (or variable (eq return :tail)) '(arg-locs)) ,@(unless variable '(nargs)) ,@(when (eq named :direct) '(fun)) ,@(when (eq return :fixed) '(nvals)) - step-instrumenting) + step-instrumenting + ,@(unless named + '(fun-type))) (:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs)) ,@(unless variable '(args)) - ,(ecase return - (:fixed 'ocfp-temp) - (:tail 'old-fp) - (:unknown 'r0-temp))) + ,@(ecase return + (:fixed '(ocfp-temp)) + (:tail '(old-fp return-pc node)) + (:unknown '(r0-temp node)))) ,@(unless (eq named :direct) `((:temporary (:sc descriptor-reg :offset lexenv-offset :from (:argument ,(if (eq return :tail) 0 1)) :to :eval) - ,(if named 'name-pass 'lexenv)) - (:temporary (:scs (descriptor-reg) :to :eval) + ,(if named 'name-pass 'lexenv)))) + + ,@(unless named + `((:temporary (:scs (descriptor-reg) :to :eval) function))) (:temporary (:sc any-reg :offset nargs-offset :to @@ -865,7 +905,7 @@ `(:temporary (:sc descriptor-reg :offset ,offset :to :result) - ,name)) + ,name)) *register-arg-names* *register-arg-offsets*)) ,@(when (eq return :fixed) '((:temporary (:scs (descriptor-reg) :from :eval) move-temp) @@ -881,143 +921,131 @@ (if (eq return :tail) 0 10) 15 (if (eq return :unknown) 25 0)) - (let* ((cur-nfp (current-nfp-tn vop)) - ,@(unless (eq return :tail) - '((lra-label (gen-label)))) - (filler - (remove nil - (list ,@(if (eq return :tail) - '(:load-nargs - (unless (location= return-pc - (make-random-tn :kind :normal - :sc (sc-or-lose 'control-stack) - :offset lra-save-offset)) - :load-return-pc) - (when cur-nfp - :frob-nfp)) - '(:load-nargs - :comp-lra - (when cur-nfp - :frob-nfp) - :load-fp)))))) - (flet ((do-next-filler () - (let* ((next (pop filler)) - (what (if (consp next) (car next) next))) - (ecase what - (:load-nargs - ,@(if variable - `((move nargs-pass csp-tn) - ;; The variable args are on the stack - ;; and become the frame, but there may - ;; be <4 args and 2 stack slots are - ;; assumed allocate on the call. So - ;; need to ensure there are at least 2 - ;; slots. This just adds 2 more. - (inst add csp-tn nargs-pass (* 2 n-word-bytes)) - (inst sub nargs-pass nargs-pass new-fp) - (inst asr nargs-pass nargs-pass (- word-shift n-fixnum-tag-bits)) - ,@(do ((arg *register-arg-names* (cddr arg)) - (i 0 (+ i 2)) - (insts)) - ((null arg) (nreverse insts)) - #.(assert (evenp register-arg-count)) - (push `(inst ldp ,(first arg) ,(second arg) - (@ new-fp ,(* i n-word-bytes))) - insts)) - (storew cfp-tn new-fp ocfp-save-offset)) - '((load-immediate-word nargs-pass (fixnumize nargs))))) - ,@(if (eq return :tail) - '((:load-return-pc - (error "RETURN-PC not in its passing location")) - (:frob-nfp - (inst add nsp-tn cur-nfp (add-sub-immediate - (bytes-needed-for-non-descriptor-stack-frame))))) - `((:comp-lra - (inst compute-lra lip lip lra-label) - (inst str lip (@ new-fp (* lra-save-offset - n-word-bytes)))) - (:frob-nfp - (store-stack-tn nfp-save cur-nfp)) - (:load-fp - (move cfp-tn new-fp)))) - ((nil))))) - (insert-step-instrumenting () - ;; Conditionally insert a conditional trap: - (when step-instrumenting - (assemble () - #-sb-thread - (load-symbol-value tmp-tn sb-impl::*stepping*) - #+sb-thread - (loadw tmp-tn thread-tn thread-stepping-slot) - (inst cbz tmp-tn step-done-label) - ;; CONTEXT-PC will be pointing here when the - ;; interrupt is handled, not after the - ;; DEBUG-TRAP. - (note-this-location vop :internal-error) - (inst brk single-step-around-trap) - STEP-DONE-LABEL)))) - (declare (ignorable #'insert-step-instrumenting)) - ,@(case named - ((t) - `((sc-case name - (descriptor-reg (move name-pass name)) - (control-stack - (load-stack-tn name-pass name) - (do-next-filler)) - (constant - (load-constant vop name name-pass) - (do-next-filler))) - (do-next-filler) - (insert-step-instrumenting))) - ((nil) - `((sc-case arg-fun - (descriptor-reg (move lexenv arg-fun)) - (control-stack - (load-stack-tn lexenv arg-fun) - (do-next-filler)) - (constant - (load-constant vop arg-fun lexenv) - (do-next-filler))) - (insert-step-instrumenting) - (loadw function lexenv closure-fun-slot - fun-pointer-lowtag) - (do-next-filler)))) - (loop - (if filler - (do-next-filler) - (return))) - ,@(ecase named - ;; raw-addr is an untagged pointer to the function, - ;; need to pair it up with the tagged pointer for the GC to see - ((t) - `((loadw function name-pass fdefn-fun-slot - other-pointer-lowtag) - (loadw lip name-pass fdefn-raw-addr-slot - other-pointer-lowtag))) - (:direct - `((inst ldr lip (@ null-tn (load-store-offset (static-fun-offset fun)))))) - ((nil) - `((inst add lip function - (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag))))) - - (note-this-location vop :call-site) - (inst br lip)) - - ,@(ecase return - (:fixed - '((emit-return-pc lra-label) - (default-unknown-values vop values nvals move-temp lip lra-label) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:unknown - '((emit-return-pc lra-label) - (note-this-location vop :unknown-return) - (receive-unknown-values values-start nvals start count - lra-label lip) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save)))) - (:tail)))))) + (let* ((cur-nfp (current-nfp-tn vop)) + (filler + (remove nil + (list ,@(if (eq return :tail) + '(:load-nargs + (when cur-nfp + :frob-nfp)) + '(:load-nargs + (when cur-nfp + :frob-nfp) + :load-fp)))))) + (flet ((do-next-filler () + (let* ((next (pop filler)) + (what (if (consp next) (car next) next))) + (ecase what + (:load-nargs + ,@(if variable + `((move nargs-pass csp-tn) + ;; The variable args are on the stack + ;; and become the frame, but there may + ;; be <4 args and 2 stack slots are + ;; assumed allocate on the call. So + ;; need to ensure there are at least 2 + ;; slots. This just adds 2 more. + (inst add csp-tn nargs-pass (* 2 n-word-bytes)) + (inst sub nargs-pass nargs-pass new-fp) + (inst asr nargs-pass nargs-pass (- word-shift n-fixnum-tag-bits)) + ,@(do ((arg *register-arg-names* (cddr arg)) + (i 0 (+ i 2)) + (insts)) + ((null arg) (nreverse insts)) + #.(assert (evenp register-arg-count)) + (push `(inst ldp ,(first arg) ,(second arg) + (@ new-fp ,(* i n-word-bytes))) + insts)) + (storew cfp-tn new-fp ocfp-save-offset)) + '((load-immediate-word nargs-pass (fixnumize nargs))))) + ,@(if (eq return :tail) + '((:frob-nfp + (inst add nsp-tn cur-nfp (add-sub-immediate + (bytes-needed-for-non-descriptor-stack-frame))))) + `((:frob-nfp + (store-stack-tn nfp-save cur-nfp)) + (:load-fp + (move cfp-tn (cond ,@(and + (not variable) + '(((<= nargs register-arg-count) + csp-tn))) + (t + new-fp)))))) + ((nil))))) + (insert-step-instrumenting () + ;; Conditionally insert a conditional trap: + (when step-instrumenting + (assemble () + #-sb-thread + (load-symbol-value tmp-tn sb-impl::*stepping*) + #+sb-thread + (loadw tmp-tn thread-tn thread-stepping-slot) + (inst cbz tmp-tn step-done-label) + ;; CONTEXT-PC will be pointing here when the + ;; interrupt is handled, not after the + ;; DEBUG-TRAP. + (note-this-location vop :internal-error) + (inst brk single-step-around-trap) + STEP-DONE-LABEL)))) + (declare (ignorable #'insert-step-instrumenting)) + ,@(case named + ((t) + `((sc-case name + (descriptor-reg (move name-pass name)) + (control-stack + (load-stack-tn name-pass name) + (do-next-filler)) + (constant + (load-constant vop name name-pass) + (do-next-filler))) + (do-next-filler) + (insert-step-instrumenting))) + ((nil) + `((sc-case arg-fun + (descriptor-reg (move lexenv arg-fun)) + (control-stack + (load-stack-tn lexenv arg-fun) + (do-next-filler)) + (constant + (load-constant vop arg-fun lexenv) + (do-next-filler))) + (insert-step-instrumenting) + (do-next-filler)))) + (loop + (if filler + (do-next-filler) + (return))) + ,@(case named + ((t) + `((loadw lip name-pass fdefn-raw-addr-slot other-pointer-lowtag) + ,(if (eq return :tail) + `(inst add lip lip 4)))) + (:direct + `((inst ldr lip (@ null-tn (load-store-offset (static-fun-offset fun)))) + ,(if (eq return :tail) + `(inst add lip lip 4))))) + + (note-this-location vop :call-site) + + ,(if named + (if (eq return :tail) + `(inst br lip) + `(inst blr lip)) + (if (eq return :tail) + `(tail-call-unnamed lexenv function lip fun-type) + `(call-unnamed lexenv function lip fun-type)))) + + ,@(ecase return + (:fixed + '((default-unknown-values vop values nvals move-temp node) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:unknown + '((note-this-location vop :unknown-return) + (receive-unknown-values values-start nvals start count) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save)))) + (:tail)))))) (define-full-call call nil :fixed nil) (define-full-call call-named t :fixed nil) @@ -1040,6 +1068,7 @@ (function-arg :scs (descriptor-reg) :target lexenv) (old-fp-arg :scs (any-reg) :load-if nil) (lra-arg :scs (descriptor-reg) :load-if nil)) + (:info fun-type) (:temporary (:sc any-reg :offset nl2-offset :from (:argument 0)) args) (:temporary (:sc descriptor-reg :offset lexenv-offset :from (:argument 1)) lexenv) (:temporary (:scs (interior-reg)) lip) @@ -1054,18 +1083,66 @@ (when cur-nfp (inst add nsp-tn cur-nfp (add-sub-immediate (bytes-needed-for-non-descriptor-stack-frame))))) - (load-inline-constant tmp-tn '(:fixup tail-call-variable :assembly-routine) lip) + (load-inline-constant tmp-tn + (if (eq fun-type :function) + '(:fixup tail-call-variable :assembly-routine) + '(:fixup tail-call-callable-variable :assembly-routine)) + lip) (inst br tmp-tn))) + +;;; Invoke the function-designator FUN. +(defun tail-call-unnamed (lexenv fun lip type) + (case type + (:symbol + (load-inline-constant tmp-tn '(:fixup tail-call-symbol :assembly-routine)) + (inst br tmp-tn)) + (t + (assemble () + (when (eq type :designator) + (inst and tmp-tn lexenv lowtag-mask) + (inst cmp tmp-tn fun-pointer-lowtag) + (inst b :eq call) + (load-inline-constant tmp-tn '(:fixup tail-call-symbol :assembly-routine)) + (inst br tmp-tn)) + call + (loadw fun lexenv closure-fun-slot fun-pointer-lowtag) + (inst add lip fun + (+ (- (ash simple-fun-insts-offset word-shift) + fun-pointer-lowtag) + 4)) + (inst br lip))))) + +(defun call-unnamed (lexenv fun lip type) + (case type + (:symbol + (load-inline-constant tmp-tn '(:fixup call-symbol :assembly-routine)) + (inst blr tmp-tn)) + (t + (assemble () + (when (eq type :designator) + (inst and tmp-tn lexenv lowtag-mask) + (inst cmp tmp-tn fun-pointer-lowtag) + (inst b :eq call) + (load-inline-constant tmp-tn '(:fixup call-symbol :assembly-routine)) + (inst blr tmp-tn) + (inst b ret)) + call + (loadw fun lexenv closure-fun-slot fun-pointer-lowtag) + (inst add lip fun + (- (ash simple-fun-insts-offset word-shift) + fun-pointer-lowtag)) + (inst blr lip) + ret)))) ;;;; Unknown values return: ;;; Return a single value using the unknown-values convention. (define-vop (return-single) - (:args (old-fp :scs (any-reg) :to :eval) - (return-pc :scs (descriptor-reg)) + (:args (old-fp) + (return-pc) (value)) (:temporary (:scs (interior-reg)) lip) - (:ignore value) + (:ignore value old-fp return-pc) (:vop-var vop) (:generator 6 ;; Clear the number stack. @@ -1073,12 +1150,14 @@ (when cur-nfp (inst add nsp-tn cur-nfp (add-sub-immediate (bytes-needed-for-non-descriptor-stack-frame))))) - ;; Clear the control stack, and restore the frame pointer. + ;; Interrupts leave two words of space for the new frame, so it's safe + ;; to deallocate the frame before accessing OCFP/LR. (move csp-tn cfp-tn) - (move cfp-tn old-fp) + (loadw-pair cfp-tn ocfp-save-offset lip lra-save-offset cfp-tn) + ;; Clear the control stack, and restore the frame pointer. ;; Out of here. - (lisp-return return-pc lip :single-value))) + (lisp-return lip :single-value))) ;;; Do unknown-values return of a fixed number of values. The Values are ;;; required to be set up in the standard passing locations. Nvals is the @@ -1094,10 +1173,10 @@ ;;; current frame.) (define-vop (return) (:args - (old-fp :scs (any-reg)) - (return-pc :scs (descriptor-reg) :to (:eval 1)) + (old-fp) + (return-pc) (values :more t)) - (:ignore values) + (:ignore values old-fp return-pc) (:info nvals) (:temporary (:sc descriptor-reg :offset r0-offset :from (:eval 0)) r0) (:temporary (:sc descriptor-reg :offset r1-offset :from (:eval 0)) r1) @@ -1116,15 +1195,15 @@ (cond ((= nvals 1) ;; Clear the control stack, and restore the frame pointer. (move csp-tn cfp-tn) - (move cfp-tn old-fp) + (loadw-pair cfp-tn ocfp-save-offset lip lra-save-offset cfp-tn) ;; Out of here. - (lisp-return return-pc lip :single-value)) + (lisp-return lip :single-value)) (t ;; Establish the values pointer. (move val-ptr cfp-tn) ;; restore the frame pointer and clear as much of the control ;; stack as possible. - (move cfp-tn old-fp) + (loadw-pair cfp-tn ocfp-save-offset lip lra-save-offset cfp-tn) (inst add csp-tn val-ptr (add-sub-immediate (* nvals n-word-bytes))) ;; Establish the values count. (load-immediate-word nargs (fixnumize nvals)) @@ -1133,7 +1212,7 @@ (dolist (reg (subseq (list r0 r1 r2 r3) nvals)) (move reg null-tn))) ;; And away we go. - (lisp-return return-pc lip :multiple-values))))) + (lisp-return lip :multiple-values))))) ;;; Do unknown-values return of an arbitrary number of values (passed ;;; on the stack.) We check for the common case of a single return @@ -1143,18 +1222,17 @@ (define-vop (return-multiple) (:args (old-fp-arg :scs (any-reg) :to (:eval 1)) - (lra-arg :scs (descriptor-reg) :to (:eval 1)) + (lra-arg) (vals-arg :scs (any-reg) :target vals) (nvals-arg :scs (any-reg) :target nvals)) (:temporary (:sc any-reg :offset nl2-offset :from (:argument 0)) old-fp) - (:temporary (:sc descriptor-reg :offset r6-offset :from (:argument 1)) lra) (:temporary (:sc any-reg :offset nl1-offset :from (:argument 2)) vals) (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals) (:temporary (:sc descriptor-reg :offset r0-offset) r0) (:temporary (:sc interior-reg) lip) (:vop-var vop) (:generator 13 - (move lra lra-arg) + (maybe-load-stack-tn lip lra-arg) ;; Clear the number stack. (let ((cur-nfp (current-nfp-tn vop))) (when cur-nfp @@ -1169,7 +1247,7 @@ (inst ldr r0 (@ vals-arg)) (move csp-tn cfp-tn) (move cfp-tn old-fp-arg) - (lisp-return lra lip :single-value) + (lisp-return lip :single-value) NOT-SINGLE (move old-fp old-fp-arg) diff -Nru sbcl-2.1.1/src/compiler/arm64/c-call.lisp sbcl-2.1.11/src/compiler/arm64/c-call.lisp --- sbcl-2.1.1/src/compiler/arm64/c-call.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/c-call.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -33,30 +33,73 @@ nl7-offset) index)) -(defun int-arg (state prim-type reg-sc stack-sc) +(define-vop (move-word-arg-stack) + (:args (x :scs (signed-reg unsigned-reg single-reg)) + (fp :scs (any-reg))) + (:info size offset) + (:generator 0 + (let ((addr (@ fp (load-store-offset offset)))) + (ecase size + (1 + (inst strb x addr)) + (2 + (inst strh x addr)) + (4 + (inst str (if (sc-is x single-reg) + x + (32-bit-reg x)) + addr)))))) + +(defun move-to-stack-location (value size offset prim-type sc node block nsp) + (let ((temp-tn (sb-c:make-representation-tn + (primitive-type-or-lose prim-type) + sc))) + (sb-c::emit-move node + block + (sb-c::lvar-tn node block value) + temp-tn) + (sb-c::vop move-word-arg-stack node block temp-tn nsp size offset))) + +(defun int-arg (state prim-type reg-sc stack-sc &optional (size 8)) (let ((reg-args (arg-state-num-register-args state))) (cond ((< reg-args +max-register-args+) (setf (arg-state-num-register-args state) (1+ reg-args)) (make-wired-tn* prim-type reg-sc (register-args-offset reg-args))) (t - (let ((frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ frame-size)) - (make-wired-tn* prim-type stack-sc frame-size)))))) + (let ((frame-size (align-up (arg-state-stack-frame-size state) size))) + (setf (arg-state-stack-frame-size state) (+ frame-size size)) + (cond #+darwin + ((/= size n-word-bytes) + (lambda (value node block nsp) + (move-to-stack-location value size frame-size + prim-type reg-sc node block nsp))) + (t + (make-wired-tn* prim-type stack-sc (truncate frame-size size))))))))) -(defun float-arg (state prim-type reg-sc stack-sc) +(defun float-arg (state prim-type reg-sc stack-sc &optional (size 8)) (let ((reg-args (arg-state-fp-registers state))) (cond ((< reg-args +max-register-args+) (setf (arg-state-fp-registers state) (1+ reg-args)) (make-wired-tn* prim-type reg-sc reg-args)) (t - (let ((frame-size (arg-state-stack-frame-size state))) - (setf (arg-state-stack-frame-size state) (1+ frame-size)) - (make-wired-tn* prim-type stack-sc frame-size)))))) + (let ((frame-size (align-up (arg-state-stack-frame-size state) size))) + (setf (arg-state-stack-frame-size state) (+ frame-size size)) + (cond #+darwin + ((/= size n-word-bytes) + (lambda (value node block nsp) + (move-to-stack-location value size frame-size + prim-type reg-sc node block nsp))) + (t + (make-wired-tn* prim-type stack-sc (truncate frame-size size))))))))) (define-alien-type-method (integer :arg-tn) (type state) - (if (alien-integer-type-signed type) - (int-arg state 'signed-byte-64 signed-reg-sc-number signed-stack-sc-number) - (int-arg state 'unsigned-byte-64 unsigned-reg-sc-number unsigned-stack-sc-number))) + (let ((size #+darwin (truncate (alien-type-bits type) n-byte-bits) + #-darwin n-word-bytes)) + (if (alien-integer-type-signed type) + (int-arg state 'signed-byte-64 signed-reg-sc-number signed-stack-sc-number + size) + (int-arg state 'unsigned-byte-64 unsigned-reg-sc-number unsigned-stack-sc-number + size)))) (define-alien-type-method (system-area-pointer :arg-tn) (type state) (declare (ignore type)) @@ -64,7 +107,7 @@ (define-alien-type-method (single-float :arg-tn) (type state) (declare (ignore type)) - (float-arg state 'single-float single-reg-sc-number single-stack-sc-number)) + (float-arg state 'single-float single-reg-sc-number single-stack-sc-number #+darwin 4)) (define-alien-type-method (double-float :arg-tn) (type state) (declare (ignore type)) @@ -135,10 +178,16 @@ (defun make-call-out-tns (type) (let ((arg-state (make-arg-state))) (collect ((arg-tns)) - (dolist (arg-type (alien-fun-type-arg-types type)) - (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state))) + (let (#+darwin (variadic (sb-alien::alien-fun-type-varargs type))) + (loop for i from 0 + for arg-type in (alien-fun-type-arg-types type) + do + #+darwin + (when (eql i variadic) + (setf (arg-state-num-register-args arg-state) +max-register-args+)) + (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))) (values (make-normal-tn *fixnum-primitive-type*) - (* (arg-state-stack-frame-size arg-state) n-word-bytes) + (arg-state-stack-frame-size arg-state) (arg-tns) (invoke-alien-type-method :result-tn (alien-fun-type-result-type type) @@ -169,30 +218,88 @@ (load-inline-constant res `(:fixup ,foreign-symbol :foreign-dataref) lip) (inst ldr res (@ res)))) +(defun emit-c-call (vop nfp-save temp temp2 lip cfunc function) + (let ((cur-nfp (current-nfp-tn vop))) + (when cur-nfp + (store-stack-tn nfp-save cur-nfp)) + (if (stringp function) + (load-inline-constant cfunc `(:fixup ,function :foreign) lip) + (sc-case function + (sap-reg (move cfunc function)) + (sap-stack + (load-stack-offset cfunc cur-nfp function)))) + (assemble () + #+sb-thread + (progn + (inst add temp csp-tn (* 2 n-word-bytes)) + ;; Build a new frame to stash a pointer to the current code object + ;; for the GC to see. + (inst adr temp2 return) + (inst stp cfp-tn temp2 (@ csp-tn)) + (storew-pair csp-tn thread-control-frame-pointer-slot temp thread-control-stack-pointer-slot thread-tn) + (inst blr cfunc) + + (loop for reg in (list r0-offset r1-offset r2-offset r3-offset + r4-offset r5-offset r6-offset r7-offset + #-darwin r10-offset) + do + (inst mov + (make-random-tn + :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset reg) + 0)) + (storew zr-tn thread-tn thread-control-stack-pointer-slot)) + return + #-sb-thread + (progn + temp2 + (load-inline-constant temp '(:fixup "call_into_c" :foreign) lip) + (inst blr temp)) + (when cur-nfp + (load-stack-tn cur-nfp nfp-save))))) + +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) + (defun destroyed-c-registers () + (let ((gprs (list nl0-offset nl1-offset nl2-offset nl3-offset + nl4-offset nl5-offset nl6-offset nl7-offset nl8-offset nl9-offset + r0-offset r1-offset r2-offset r3-offset + r4-offset r5-offset r6-offset r7-offset + #-darwin r10-offset + #-sb-thread r11-offset)) + (vars)) + (append + (loop for gpr in gprs + collect `(:temporary (:sc any-reg :offset ,gpr :from :eval :to :result) + ,(car (push (sb-xc:gensym) vars)))) + (loop for float to 31 + collect `(:temporary (:sc single-reg :offset ,float :from :eval :to :result) + ,(car (push (sb-xc:gensym) vars)))) + `((:ignore ,@vars)))))) + (define-vop (call-out) (:args (function :scs (sap-reg sap-stack)) (args :more t)) (:results (results :more t)) (:ignore args results) - (:save-p t) - (:temporary (:sc any-reg :offset r8-offset + (:temporary (:sc any-reg :offset r9-offset :from (:argument 0) :to (:result 0)) cfunc) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) - (:temporary (:sc any-reg :offset r9-offset) temp) + (:temporary (:sc any-reg :offset r8-offset) temp) + (:temporary (:sc any-reg :offset lexenv-offset) temp2) (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 0 - (let ((cur-nfp (current-nfp-tn vop))) - (when cur-nfp - (store-stack-tn nfp-save cur-nfp)) - (load-inline-constant temp '(:fixup "call_into_c" :foreign) lip) - (sc-case function - (sap-reg (move cfunc function)) - (sap-stack - (load-stack-offset cfunc cur-nfp function))) - (inst blr temp) - (when cur-nfp - (load-stack-tn cur-nfp nfp-save))))) + (emit-c-call vop nfp-save temp temp2 lip cfunc function)) + . + #. (destroyed-c-registers)) + +;;; Manually load the fixup instead of using foreign-symbol-sap, +;;; because it wants to go to r9, which is not compatible with sap-reg. +(define-vop (call-out-named call-out) + (:args (args :more t)) + (:info function variadic) + (:ignore args results variadic)) (define-vop (alloc-number-stack-space) (:info amount) @@ -216,8 +323,8 @@ ;;; long-long support ;; (deftransform %alien-funcall ((function type &rest args) * * :node node) -;; (aver (sb-c::constant-lvar-p type)) -;; (let* ((type (sb-c::lvar-value type)) +;; (aver (sb-c:constant-lvar-p type)) +;; (let* ((type (sb-c:lvar-value type)) ;; (env (sb-c::node-lexenv node)) ;; (arg-types (alien-fun-type-arg-types type)) ;; (result-type (alien-fun-type-result-type type))) @@ -310,7 +417,7 @@ ;; How many arguments have been copied (arg-count 0) ;; How many arguments have been copied from the stack - (stack-argument-count 0) + (stack-argument-bytes 0) (r0-tn (make-tn 0)) (r1-tn (make-tn 1)) (r2-tn (make-tn 2)) @@ -333,9 +440,8 @@ ;; Copy arguments (dolist (type argument-types) (let ((target-tn (@ nsp-tn (* arg-count n-word-bytes))) - ;; A TN pointing to the stack location that contains - ;; the next argument passed on the stack. - (stack-arg-tn (@ nsp-save-tn (* stack-argument-count n-word-bytes)))) + (size #+darwin (truncate (alien-type-bits type) n-byte-bits) + #-darwin n-word-bytes)) (cond ((or (alien-integer-type-p type) (alien-pointer-type-p type) (alien-type-= #.(parse-alien-type 'system-area-pointer nil) @@ -344,9 +450,30 @@ (cond (gpr (inst str gpr target-tn)) (t - (incf stack-argument-count) - (inst ldr temp-tn stack-arg-tn) - (inst str temp-tn target-tn)))) + (setf stack-argument-bytes + (align-up stack-argument-bytes size)) + (let ((addr (@ nsp-save-tn stack-argument-bytes))) + (cond #+darwin + ((/= size 8) + (let ((signed (and (alien-integer-type-p type) + (alien-integer-type-signed type)))) + (ecase size + (1 + (if signed + (inst ldrsb temp-tn addr) + (inst ldrb temp-tn addr))) + (2 + (if signed + (inst ldrsh temp-tn addr) + (inst ldrh temp-tn addr))) + (4 + (if signed + (inst ldrsw (32-bit-reg temp-tn) addr) + (inst ldr (32-bit-reg temp-tn) addr)))))) + (t + (inst ldr temp-tn addr))) + (inst str temp-tn target-tn)) + (incf stack-argument-bytes size)))) (incf arg-count)) ((alien-float-type-p type) (cond ((< fp-registers 8) @@ -356,9 +483,18 @@ 'double-reg)) target-tn)) (t - (incf stack-argument-count) - (inst ldr temp-tn stack-arg-tn) - (inst str temp-tn target-tn))) + (setf stack-argument-bytes + (align-up stack-argument-bytes size)) + (case size + #+darwin + (4 + (let ((reg (32-bit-reg temp-tn))) + (inst ldr reg (@ nsp-save-tn stack-argument-bytes)) + (inst str reg target-tn))) + (t + (inst ldr temp-tn (@ nsp-save-tn stack-argument-bytes)) + (inst str temp-tn target-tn))) + (incf stack-argument-bytes size))) (incf fp-registers) (incf arg-count)) (t @@ -404,9 +540,13 @@ ;; Now that the segment is done, convert it to a static ;; vector we can point foreign code to. (let* ((buffer (sb-assem:segment-buffer segment)) - (vector (make-static-vector (length buffer) + (vector #-darwin-jit + (make-static-vector (length buffer) :element-type '(unsigned-byte 8) - :initial-contents buffer)) + :initial-contents buffer) + #+darwin-jit + (make-static-code-vector (length buffer) + buffer)) (sap (vector-sap vector))) (alien-funcall (extern-alien "os_flush_icache" diff -Nru sbcl-2.1.1/src/compiler/arm64/cell.lisp sbcl-2.1.11/src/compiler/arm64/cell.lisp --- sbcl-2.1.1/src/compiler/arm64/cell.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/cell.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -24,17 +24,13 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) + (value :scs (descriptor-reg any-reg zero))) (:info name offset lowtag) (:ignore name) (:results) (:generator 1 (storew value object offset lowtag))) -(define-vop (init-slot set-slot) - (:info name dx-p offset lowtag) - (:ignore name dx-p)) - (define-vop (compare-and-swap-slot) (:args (object :scs (descriptor-reg)) (old :scs (descriptor-reg any-reg)) @@ -44,17 +40,22 @@ (:temporary (:sc interior-reg) lip) (:results (result :scs (descriptor-reg any-reg) :from :load)) (:generator 5 - (inst dsb) (inst add-sub lip object (- (* offset n-word-bytes) lowtag)) - LOOP - (inst ldxr result lip) - (inst cmp result old) - (inst b :ne EXIT) - (inst stlxr tmp-tn new lip) - (inst cbnz tmp-tn LOOP) - EXIT - (inst clrex) - (inst dmb))) + (cond ((member :arm-v8.1 *backend-subfeatures*) + (move result old) + (inst casal result new lip)) + (t + (assemble () + (inst dsb) + LOOP + (inst ldxr result lip) + (inst cmp result old) + (inst b :ne EXIT) + (inst stlxr tmp-tn new lip) + (inst cbnz tmp-tn LOOP) + EXIT + (inst clrex) + (inst dmb)))))) ;;;; Symbol hacking VOPs: @@ -66,13 +67,6 @@ (:policy :fast-safe) (:vop-var vop) (:save-p :compute-only)) -;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound. -(define-vop (boundp-frob) - (:args (object :scs (descriptor-reg))) - (:conditional) - (:info target not-p) - (:policy :fast-safe) - (:temporary (:scs (descriptor-reg)) value)) ;;; With Symbol-Value, we check that the value isn't the trap object. So ;;; Symbol-Value of NIL is NIL. @@ -80,7 +74,7 @@ (progn (define-vop (set) (:args (object :scs (descriptor-reg)) - (value :scs (descriptor-reg any-reg))) + (value :scs (descriptor-reg any-reg zero))) (:temporary (:sc any-reg) tls-index) (:generator 4 (inst ldr (32-bit-reg tls-index) (tls-index-of object)) @@ -95,38 +89,52 @@ (define-vop (symbol-value checked-cell-ref) (:translate symeval) + (:args (symbol :scs (descriptor-reg) :to :save + :load-if (not (and (sc-is symbol constant) + (or (symbol-always-has-tls-value-p (tn-value symbol)) + (symbol-always-has-tls-index-p (tn-value symbol))))))) + (:args-var symbol-tn-ref) (:temporary (:sc any-reg) tls-index) (:variant-vars check-boundp) (:variant t) (:generator 9 - (inst ldr (32-bit-reg tls-index) (tls-index-of object)) - (inst ldr value (@ thread-tn tls-index)) - (inst cmp value no-tls-value-marker-widetag) - (inst b :ne LOCAL) - (loadw value object symbol-value-slot other-pointer-lowtag) - LOCAL + (let* ((known-symbol-p (sc-is symbol constant)) + (known-symbol (and known-symbol-p (tn-value symbol))) + (fixup (and known-symbol + (make-fixup known-symbol :symbol-tls-index)))) + (cond + ((symbol-always-has-tls-value-p known-symbol) + (inst ldr value (@ thread-tn fixup))) + (t + (cond + (known-symbol ; e.g. CL:*PRINT-BASE* + ;; Known nonzero TLS index, but possibly no per-thread value. + ;; The TLS value and global value can be loaded independently. + (inst ldr value (@ thread-tn fixup))) + (t + (inst ldr (32-bit-reg tls-index) (tls-index-of symbol)) + (inst ldr value (@ thread-tn tls-index)))) + + (assemble () + (inst cmp value no-tls-value-marker-widetag) + (inst b :ne LOCAL) + (when known-symbol + (load-constant vop symbol (setf symbol (tn-ref-load-tn symbol-tn-ref)))) + (loadw value symbol symbol-value-slot other-pointer-lowtag) + LOCAL)))) + (when check-boundp - (let ((err-lab (generate-error-code vop 'unbound-symbol-error object))) - (inst cmp value unbound-marker-widetag) - (inst b :eq err-lab))))) + (assemble () + (let* ((*location-context* (make-restart-location RETRY value)) + (err-lab (generate-error-code vop 'unbound-symbol-error symbol))) + (inst cmp value unbound-marker-widetag) + (inst b :eq err-lab)) + RETRY)))) (define-vop (fast-symbol-value symbol-value) (:policy :fast) (:variant nil) - (:variant-cost 5)) - - (define-vop (boundp boundp-frob) - (:translate boundp) - (:temporary (:sc any-reg) tls-index) - (:generator 9 - (inst ldr (32-bit-reg tls-index) (tls-index-of object)) - (inst ldr value (@ thread-tn tls-index)) - (inst cmp value no-tls-value-marker-widetag) - (inst b :ne LOCAL) - (loadw value object symbol-value-slot other-pointer-lowtag) - LOCAL - (inst cmp value unbound-marker-widetag) - (inst b (if not-p :eq :ne) target)))) + (:variant-cost 5))) #-sb-thread (progn @@ -142,14 +150,30 @@ (define-vop (fast-symbol-value cell-ref) (:variant symbol-value-slot other-pointer-lowtag) (:policy :fast) - (:translate symeval)) + (:translate symeval))) - (define-vop (boundp boundp-frob) - (:translate boundp) - (:generator 9 +(define-vop (boundp) + (:args (object :scs (descriptor-reg))) + (:conditional) + (:info target not-p) + (:policy :fast-safe) + (:temporary (:scs (descriptor-reg)) value) + (:translate boundp) + #+sb-thread + (:generator 9 + (inst ldr (32-bit-reg value) (tls-index-of object)) + (inst ldr value (@ thread-tn value)) + (inst cmp value no-tls-value-marker-widetag) + (inst b :ne LOCAL) + (loadw value object symbol-value-slot other-pointer-lowtag) + LOCAL + (inst cmp value unbound-marker-widetag) + (inst b (if not-p :eq :ne) target)) + #-sb-thread + (:generator 9 (loadw value object symbol-value-slot other-pointer-lowtag) (inst cmp value unbound-marker-widetag) - (inst b (if not-p :eq :ne) target)))) + (inst b (if not-p :eq :ne) target))) (define-vop (%set-symbol-global-value cell-set) (:variant symbol-value-slot other-pointer-lowtag)) @@ -176,7 +200,7 @@ (:policy :fast-safe) (:translate symbol-hash) (:args (symbol :scs (descriptor-reg))) - (:temporary (:scs (non-descriptor-reg)) temp) + (:args-var args) (:results (res :scs (any-reg))) (:result-types positive-fixnum) (:generator 2 @@ -184,8 +208,9 @@ ;; car slot, so we have to strip off the fixnum-tag-mask to make sure ;; it is a fixnum. The lowtag selection magic that is required to ;; ensure this is explained in the comment in objdef.lisp - (loadw temp symbol symbol-hash-slot other-pointer-lowtag) - (inst and res temp (bic-mask fixnum-tag-mask)))) + (loadw res symbol symbol-hash-slot other-pointer-lowtag) + (unless (not-nil-tn-ref-p args) + (inst and res res (bic-mask fixnum-tag-mask))))) (define-vop (%compare-and-swap-symbol-value) (:translate %compare-and-swap-symbol-value) @@ -228,6 +253,40 @@ (inst dmb) (inst cmp result unbound-marker-widetag) (inst b :eq (generate-error-code vop 'unbound-symbol-error symbol)))) + +(define-vop (%compare-and-swap-symbol-value-v8.1) + (:translate %compare-and-swap-symbol-value) + (:args (symbol :scs (descriptor-reg)) + (old :scs (descriptor-reg any-reg)) + (new :scs (descriptor-reg any-reg))) + (:results (result :scs (descriptor-reg any-reg) :from :load)) + #+sb-thread + (:temporary (:sc any-reg) tls-index) + (:temporary (:sc interior-reg) lip) + (:policy :fast-safe) + (:vop-var vop) + (:guard (member :arm-v8.1 *backend-subfeatures*)) + (:generator 14 + #+sb-thread + (assemble () + (inst ldr (32-bit-reg tls-index) (tls-index-of symbol)) + ;; Thread-local area, no synchronization needed. + (inst ldr result (@ thread-tn tls-index)) + (inst cmp result old) + (inst b :ne DONT-STORE-TLS) + (inst str new (@ thread-tn tls-index)) + DONT-STORE-TLS + + (inst cmp result no-tls-value-marker-widetag) + (inst b :ne CHECK-UNBOUND)) + (inst add-sub lip symbol (- (* symbol-value-slot n-word-bytes) + other-pointer-lowtag)) + (move result old) + (inst casal result new lip) + CHECK-UNBOUND + (inst cmp result unbound-marker-widetag) + (inst b :eq (generate-error-code vop 'unbound-symbol-error symbol)))) + ;;;; Fdefinition (fdefn) objects. @@ -272,16 +331,13 @@ (define-vop (fdefn-makunbound) (:policy :fast-safe) (:translate fdefn-makunbound) - (:args (fdefn :scs (descriptor-reg) :target result)) + (:args (fdefn :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (interior-reg)) lip) - (:results (result :scs (descriptor-reg))) (:generator 38 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag) (load-inline-constant temp '(:fixup undefined-tramp :assembly-routine) lip) - (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag) - (move result fdefn))) - + (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag))) ;;;; Binding and Unbinding. @@ -292,10 +348,13 @@ #+sb-thread (progn (define-vop (dynbind) - (:args (value :scs (any-reg descriptor-reg) :to :save) - (symbol :scs (descriptor-reg))) + (:args (value :scs (any-reg descriptor-reg zero) :to :save) + (symbol :scs (descriptor-reg) + :load-if (not (and (sc-is symbol constant) + (or (symbol-always-has-tls-value-p (tn-value symbol)) + (symbol-always-has-tls-index-p (tn-value symbol))))))) (:temporary (:sc descriptor-reg) value-temp) - (:temporary (:sc descriptor-reg :offset r0-offset :from (:argument 1)) alloc-tls-symbol) + (:temporary (:sc descriptor-reg :offset r8-offset :from (:argument 1)) alloc-tls-symbol) (:temporary (:sc non-descriptor-reg :offset nl0-offset) tls-index) (:temporary (:sc non-descriptor-reg :offset nl1-offset) free-tls-index) (:temporary (:sc interior-reg) lip) @@ -303,19 +362,29 @@ (:temporary (:scs (any-reg)) bsp) (:generator 5 (load-binding-stack-pointer bsp) - (inst ldr (32-bit-reg tls-index) (tls-index-of symbol)) (inst add bsp bsp (* binding-size n-word-bytes)) (store-binding-stack-pointer bsp) - (inst cbnz (32-bit-reg tls-index) TLS-INDEX-VALID) - (move alloc-tls-symbol symbol) - (load-inline-constant value-temp '(:fixup alloc-tls-index :assembly-routine) lip) - (inst blr value-temp) - TLS-INDEX-VALID - - (inst ldr value-temp (@ thread-tn tls-index)) - (inst stp value-temp tls-index (@ bsp (* (- binding-value-slot binding-size) - n-word-bytes))) - (inst str value (@ thread-tn tls-index)))) + (let* ((known-symbol-p (sc-is symbol constant)) + (known-symbol (and known-symbol-p (tn-value symbol))) + (tls-index-reg tls-index) + (tls-index (if known-symbol + (make-fixup known-symbol :symbol-tls-index) + tls-index))) + (assemble () + (cond (known-symbol + (inst movz tls-index-reg tls-index)) + (t + (inst ldr (32-bit-reg tls-index) (tls-index-of symbol)) + (inst cbnz (32-bit-reg tls-index) TLS-INDEX-VALID) + (move alloc-tls-symbol symbol) + (load-inline-constant value-temp '(:fixup alloc-tls-index :assembly-routine) lip) + (inst blr value-temp))) + TLS-INDEX-VALID + (inst ldr value-temp (@ thread-tn tls-index)) + (inst stp value-temp tls-index-reg + (@ bsp (* (- binding-value-slot binding-size) + n-word-bytes))) + (inst str value (@ thread-tn tls-index)))))) (define-vop (unbind-n) (:info symbols) @@ -407,9 +476,9 @@ closure-info-offset fun-pointer-lowtag (descriptor-reg any-reg) * %closure-index-ref) -(define-full-setter set-funcallable-instance-info * - funcallable-instance-info-offset fun-pointer-lowtag - (descriptor-reg any-reg) * %set-funcallable-instance-info) +(define-full-setter %closure-index-set * + closure-info-offset fun-pointer-lowtag + (descriptor-reg any-reg) * %closure-index-set) (define-full-reffer funcallable-instance-info * funcallable-instance-info-offset fun-pointer-lowtag @@ -482,8 +551,40 @@ (define-full-reffer code-header-ref * 0 other-pointer-lowtag (descriptor-reg any-reg) * code-header-ref) -(define-full-setter code-header-set * 0 other-pointer-lowtag - (descriptor-reg any-reg) * code-header-set) +#-darwin-jit +(define-vop (code-header-set) + (:translate code-header-set) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (value :scs (any-reg descriptor-reg))) + (:arg-types * tagged-num *) + (:temporary (:scs (non-descriptor-reg)) temp card) + (:temporary (:scs (interior-reg)) lip) + (:temporary (:sc non-descriptor-reg) pa-flag) + (:generator 10 + (load-inline-constant temp `(:fixup "gc_card_table_mask" :foreign-dataref) lip) + (inst ldr temp (@ temp)) + (inst ldr (32-bit-reg temp) (@ temp)) ; 4-byte int + (pseudo-atomic (pa-flag) + ;; Compute card mark index + (inst lsr card object gencgc-card-shift) + (inst and card card temp) + ;; Load mark table base + (load-inline-constant temp `(:fixup "gc_card_mark" :foreign-dataref) lip) + (inst ldr temp (@ temp)) + (inst ldr temp (@ temp)) + ;; Touch the card mark byte. + (inst strb zr-tn (@ temp card)) + ;; set 'written' flag in the code header + ;; If two threads get here at the same time, they'll write the same byte. + (let ((byte (- #+big-endian 4 #+little-endian 3 other-pointer-lowtag))) + (inst ldrb temp (@ object byte)) + (inst orr temp temp #x40) + (inst strb temp (@ object byte))) + (inst lsl temp index (- word-shift n-fixnum-tag-bits)) + (inst sub temp temp other-pointer-lowtag) + (inst str value (@ object temp))))) ;;;; raw instance slot accessors @@ -507,11 +608,9 @@ (inst ,instruction value (@ object offset)))) ,@(when move-result `((,move-macro result value)))))) - (let ((ref-vop (symbolicate "RAW-INSTANCE-REF/" name)) - (set-vop (symbolicate "RAW-INSTANCE-SET/" name))) `(progn - (define-vop (,ref-vop) - (:translate ,(symbolicate "%" ref-vop)) + (define-vop () + (:translate ,(symbolicate "%RAW-INSTANCE-REF/" name)) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate))) @@ -520,17 +619,15 @@ (:result-types ,value-primtype) (:temporary (:scs (non-descriptor-reg)) offset) (:generator 5 ,@(emit-generator 'ldr nil))) - (define-vop (,set-vop) - (:translate ,(symbolicate "%" set-vop)) + (define-vop () + (:translate ,(symbolicate "%RAW-INSTANCE-SET/" name)) (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)) - (value :scs (,value-sc) :target result)) + (value :scs (,value-sc))) (:arg-types * positive-fixnum ,value-primtype) - (:results (result :scs (,value-sc))) - (:result-types ,value-primtype) (:temporary (:scs (non-descriptor-reg)) offset) - (:generator 5 ,@(emit-generator 'str t)))))))) + (:generator 5 ,@(emit-generator 'str nil))))))) (define-raw-slot-vops word unsigned-num unsigned-reg) (define-raw-slot-vops signed-word signed-num signed-reg) (define-raw-slot-vops single single-float single-reg @@ -566,3 +663,22 @@ (inst stlxr tmp-tn sum lip) (inst cbnz tmp-tn LOOP) (inst dmb))) + +(define-vop (raw-instance-atomic-incf/word-v8.1) + (:translate %raw-instance-atomic-incf/word) + (:policy :fast-safe) + (:args (object :scs (descriptor-reg)) + (index :scs (any-reg)) + (diff :scs (unsigned-reg))) + (:arg-types * positive-fixnum unsigned-num) + (:temporary (:sc interior-reg) lip) + (:results (result :scs (unsigned-reg) :from :load)) + (:result-types unsigned-num) + (:guard (member :arm-v8.1 *backend-subfeatures*)) + (:generator 3 + (inst add lip object (lsl index (- word-shift n-fixnum-tag-bits))) + (inst add lip lip (- (* instance-slots-offset + n-word-bytes) + instance-pointer-lowtag)) + + (inst ldaddal diff result lip))) diff -Nru sbcl-2.1.1/src/compiler/arm64/char.lisp sbcl-2.1.11/src/compiler/arm64/char.lisp --- sbcl-2.1.1/src/compiler/arm64/char.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/char.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -73,7 +73,7 @@ (define-vop (char-code) (:translate char-code) (:policy :fast-safe) - (:args (ch :scs (character-reg) :target res)) + (:args (ch :scs (character-reg))) (:arg-types character) (:results (res :scs (any-reg))) (:result-types positive-fixnum) @@ -83,7 +83,7 @@ (define-vop (code-char) (:translate code-char) (:policy :fast-safe) - (:args (code :scs (any-reg) :target res)) + (:args (code :scs (any-reg))) (:arg-types positive-fixnum) (:results (res :scs (character-reg))) (:result-types character) @@ -113,7 +113,7 @@ (defun char-immediate-p (char) (and (characterp char) - (add-sub-immediate-p (sb-xc:char-code char)))) + (add-sub-immediate-p (char-code char)))) (define-vop (character-compare/c) (:args (x :scs (character-reg))) @@ -122,7 +122,7 @@ (:policy :fast-safe) (:note "inline constant comparison") (:generator 2 - (inst cmp x (sb-xc:char-code y)))) + (inst cmp x (char-code y)))) (define-vop (fast-char=/character/c character-compare/c) (:translate char=) @@ -167,3 +167,29 @@ (:policy :fast-safe) (:generator 2 (inst cmp value base-char-code-limit))) + +(defoptimizer (sb-c::vop-optimize move-to-character) (vop) + (when (sb-c:next-vop-is vop 'char-code) + (sb-c:replace-vops 2 vop 'tagged-char-code))) + +;;; Exploit the fact that the MSB of character-widetag is 0 and that n-fixnum-tag-bits is 1. +(eval-when (:compile-toplevel) + (assert (not (logbitp 7 character-widetag)))) +(define-vop (tagged-char-code) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:note "character untagging") + (:generator 1 + (inst lsr y x (- n-widetag-bits n-fixnum-tag-bits)))) + +(defoptimizer (sb-c::vop-optimize code-char) (vop) + (when (sb-c:next-vop-is vop 'move-from-character) + (sb-c:replace-vops 2 vop 'tagged-code-char))) + +(define-vop (tagged-code-char) + (:args (x :scs (any-reg descriptor-reg))) + (:results (y :scs (any-reg descriptor-reg))) + (:note "character tagging") + (:generator 1 + (inst lsl y x (- n-widetag-bits n-fixnum-tag-bits)) + (inst add y y character-widetag))) diff -Nru sbcl-2.1.1/src/compiler/arm64/debug.lisp sbcl-2.1.11/src/compiler/arm64/debug.lisp --- sbcl-2.1.1/src/compiler/arm64/debug.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/debug.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -19,7 +19,7 @@ (:generator 1 (move res csp-tn))) -(define-vop () +(define-vop (current-fp-sap) (:translate current-fp) (:policy :fast-safe) (:results (res :scs (sap-reg))) @@ -45,15 +45,12 @@ (:policy :fast-safe) (:args (sap :scs (sap-reg)) (offset :scs (any-reg) :target temp) - (value :scs (descriptor-reg) :target result)) + (value :scs (descriptor-reg))) (:arg-types system-area-pointer positive-fixnum *) (:temporary (:scs (any-reg)) temp) - (:results (result :scs (descriptor-reg))) - (:result-types *) (:generator 5 (inst lsl temp offset (- word-shift n-fixnum-tag-bits)) - (inst str value (@ sap temp)) - (move result value))) + (inst str value (@ sap temp)))) (define-vop (code-from-mumble) (:policy :fast-safe) @@ -72,10 +69,6 @@ (inst sub code thing temp) DONE)) -(define-vop (code-from-lra code-from-mumble) - (:translate sb-di::lra-code-header) - (:variant other-pointer-lowtag)) - (define-vop (code-from-fun code-from-mumble) (:translate sb-di::fun-code-header) (:variant fun-pointer-lowtag)) diff -Nru sbcl-2.1.1/src/compiler/arm64/float.lisp sbcl-2.1.11/src/compiler/arm64/float.lisp --- sbcl-2.1.1/src/compiler/arm64/float.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/float.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -144,7 +144,7 @@ (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))) (:note "complex single float move") (:generator 0 - (inst s-mov y x))) + (move-complex-double y x))) (define-move-vop complex-single-move :move (complex-single-reg) (complex-single-reg)) @@ -154,7 +154,7 @@ (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))) (:note "complex double float move") (:generator 0 - (inst s-mov y x))) + (move-complex-double y x))) (define-move-vop complex-double-move :move (complex-double-reg) (complex-double-reg)) @@ -243,7 +243,7 @@ (:generator 2 (sc-case y (complex-double-reg - (inst s-mov y x)) + (move-complex-double y x)) (complex-double-stack (storew x nfp (tn-offset y)))))) (define-move-vop move-complex-double-float-arg :move-arg diff -Nru sbcl-2.1.1/src/compiler/arm64/insts.lisp sbcl-2.1.11/src/compiler/arm64/insts.lisp --- sbcl-2.1.1/src/compiler/arm64/insts.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,7 +14,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;; Imports from this package into SB-VM - (import '(conditional-opcode + (import '(conditional-opcode negate-condition add-sub-immediate-p fixnum-add-sub-immediate-p negative-add-sub-immediate-p encode-logical-immediate fixnum-encode-logical-immediate @@ -32,8 +32,8 @@ (defconstant-eqx +conditions+ '((:eq . 0) (:ne . 1) - (:cs . 2) (:hs . 2) - (:cc . 3) (:lo . 3) + (:hs . 2) (:cs . 2) + (:lo . 3) (:cc . 3) (:mi . 4) (:pl . 5) (:vs . 6) @@ -47,7 +47,7 @@ (:al . 14)) #'equal) -(defconstant-eqx sb-vm::+condition-name-vec+ +(defconstant-eqx +condition-name-vec+ #.(let ((vec (make-array 16 :initial-element nil))) (dolist (cond +conditions+ vec) (when (null (aref vec (cdr cond))) @@ -57,8 +57,8 @@ (defun conditional-opcode (condition) (cdr (assoc condition +conditions+ :test #'eq))) -(defun invert-condition (condition) - (aref sb-vm::+condition-name-vec+ +(defun negate-condition (condition) + (aref +condition-name-vec+ (logxor 1 (conditional-opcode condition)))) ;;;; disassembler field definitions @@ -117,8 +117,10 @@ (define-arg-type cond :printer #'print-cond) (define-arg-type ldr-str-annotation :printer #'annotate-ldr-str-imm) + (define-arg-type ldr-str-pair-annotation :printer #'annotate-ldr-str-pair) (define-arg-type ldr-str-reg-annotation :printer #'annotate-ldr-str-reg) + (define-arg-type ldr-literal-annotation :printer #'annotate-ldr-literal :sign-extend t) (define-arg-type label :sign-extend t :use-label #'use-label)) @@ -145,6 +147,11 @@ 0 1)) +(defun reg-offset (tn) + (aver (or (register-p tn) + (fp-register-p tn))) + (tn-offset tn)) + (defmacro assert-same-size (&rest things) `(assert (= ,@(loop for thing in things collect `(reg-size ,thing))) @@ -164,24 +171,18 @@ (integer (emit-dword segment word))))) -(defun emit-header-data (segment type) - (emit-back-patch segment - 8 - (lambda (segment posn) - (emit-dword segment - (logior type - (ash (+ posn - (component-header-length)) - (- n-widetag-bits - word-shift))))))) - (define-instruction simple-fun-header-word (segment) (:emitter - (emit-header-data segment simple-fun-widetag))) + (emit-back-patch segment + 8 + (lambda (segment posn) + (emit-dword segment + (logior simple-fun-widetag + (ash (+ posn + (component-header-length)) + (- n-widetag-bits + word-shift)))))))) -(define-instruction lra-header-word (segment) - (:emitter - (emit-header-data segment return-pc-widetag))) ;;;; Addressing mode 1 support @@ -470,20 +471,15 @@ (shifter-operand-p rm)) (multiple-value-bind (shift amount rm) (encode-shifted-register rm) (assert-same-size rd rn rm) - (emit-add-sub-shift-reg segment size ,op shift (tn-offset rm) - amount (tn-offset rn) (tn-offset rd)))) + (emit-add-sub-shift-reg segment size ,op shift (reg-offset rm) + amount (reg-offset rn) (reg-offset rd)))) ((extend-p rm) - (let* ((shift 0) + (let* ((shift (extend-operand rm)) (extend (ecase (extend-kind rm) (:uxtb #b00) (:uxth #b001) (:uxtw #b010) - (:lsl - (aver (or (= (extend-operand rm) 0) - (= (extend-operand rm) 3))) - (setf shift 1) - #b011) - (:uxtx #b011) + ((:lsl :uxtx) #b011) (:sxtb #b100) (:sxth #b101) (:sxtw #b110) @@ -491,8 +487,8 @@ (rm (extend-register rm))) (assert-same-size rd rn rm) (emit-add-sub-ext-reg segment size ,op - (tn-offset rm) - extend shift (tn-offset rn) (tn-offset rd)))) + (reg-offset rm) + extend shift (reg-offset rn) (reg-offset rd)))) (t (let ((imm rm) (shift 0)) @@ -503,10 +499,14 @@ shift 1)) (assert-same-size rn rd) (emit-add-sub-imm segment size ,op shift imm - (tn-offset rn) (tn-offset rd))))))))) + (reg-offset rn) (reg-offset rd))))))))) (def-add-sub add #b00 (:printer add-sub-imm ((op #b00))) + (:printer add-sub-imm ((op #b00) (rd #.nsp-offset) (imm 0)) + '('mov :tab rd ", " rn)) + (:printer add-sub-imm ((op #b00) (rn #.nsp-offset) (imm 0)) + '('mov :tab rd ", " rn)) (:printer add-sub-ext-reg ((op #b00))) (:printer add-sub-shift-reg ((op #b00)))) @@ -538,6 +538,8 @@ '('cmp :tab rn ", " rm extend)) (:printer add-sub-shift-reg ((op #b11) (rd #b11111)) '('cmp :tab rn ", " rm shift)) + (:printer add-sub-shift-reg ((op #b11) (rn #b11111) (rd #b11111)) + '('cmp :tab rn ", " rm shift)) (:printer add-sub-shift-reg ((op #b11) (rn #b11111)) '('negs :tab rd ", " rm shift))) @@ -605,7 +607,7 @@ (:printer add-sub-carry ((op ,opc))) (:emitter (emit-add-sub-carry segment +64-bit-size+ ,opc - (tn-offset rm) (tn-offset rn) (tn-offset rd))))) + (reg-offset rm) (reg-offset rn) (reg-offset rd))))) (def-add-sub-carry adc #b00) (def-add-sub-carry adcs #b01) @@ -749,13 +751,15 @@ (when (shifter-operand-p rm) (setf shift (shifter-operand-function-code rm) amount (shifter-operand-operand rm))) - (emit-logical-reg segment +64-bit-size+ opc - shift n (tn-offset + (emit-logical-reg segment + (reg-size rd) + opc + shift n (reg-offset (if (shifter-operand-p rm) (shifter-operand-register rm) rm)) amount - (tn-offset rn) (tn-offset rd)))) + (reg-offset rn) (reg-offset rd)))) (defmacro def-logical-imm-and-reg (name opc &rest printers) `(define-instruction ,name (segment rd rn rm) @@ -768,7 +772,7 @@ (encode-logical-immediate rm) (unless n (error 'cannot-encode-immediate-operand :value rm)) - (emit-logical-imm segment +64-bit-size+ ,opc n immr imms (tn-offset rn) (tn-offset rd))))))) + (emit-logical-imm segment +64-bit-size+ ,opc n immr imms (reg-offset rn) (reg-offset rd))))))) (def-logical-imm-and-reg and #b00 (:printer logical-imm ((op #b00) (n 0))) @@ -839,7 +843,7 @@ (imms :field (byte 6 10) :type 'unsigned-immediate) (rn :field (byte 5 5) :type 'reg) (rd :field (byte 5 0) :type 'reg) - (lsl-alias :fields (list (byte 6 16) (byte 6 10)))) + (ubfm-alias :fields (list (byte 6 16) (byte 6 10)))) (define-instruction sbfm (segment rd rn immr imms) @@ -848,13 +852,13 @@ '('asr :tab rd ", " rn ", " immr)) (:emitter (emit-bitfield segment +64-bit-size+ 0 +64-bit-size+ - immr imms (tn-offset rn) (tn-offset rd)))) + immr imms (reg-offset rn) (reg-offset rd)))) (define-instruction bfm (segment rd rn immr imms) (:printer bitfield ((op 1))) (:emitter (emit-bitfield segment +64-bit-size+ 1 +64-bit-size+ - immr imms (tn-offset rn) (tn-offset rd)))) + immr imms (reg-offset rn) (reg-offset rd)))) (define-instruction ubfm (segment rd rn immr imms) (:printer bitfield ((op #b10) (imms #b111111)) @@ -862,12 +866,12 @@ (:printer bitfield ((op #b10)) ;; This ought to have a better solution. ;; The whole disassembler ought to be better... - '((:using #'print-lsl-alias-name lsl-alias) + '((:using #'print-ubfm-alias-name ubfm-alias) :tab rd ", " rn ", " - (:using #'print-lsl-alias lsl-alias))) + (:using #'print-ubfm-alias ubfm-alias))) (:emitter (emit-bitfield segment +64-bit-size+ #b10 +64-bit-size+ - immr imms (tn-offset rn) (tn-offset rd)))) + immr imms (reg-offset rn) (reg-offset rd)))) (define-instruction-macro asr (rd rn shift) `(let ((rd ,rd) @@ -935,10 +939,10 @@ (assert-same-size rd rn rm) (let ((size (reg-size rd))) (emit-extract segment size size - (tn-offset rm) + (reg-offset rm) lsb - (tn-offset rn) - (tn-offset rd))))) + (reg-offset rn) + (reg-offset rd))))) ;;; @@ -972,19 +976,26 @@ (:printer move-wide ((op #b00))) (:emitter (aver (not (ldb-test (byte 4 0) shift))) - (emit-move-wide segment +64-bit-size+ #b00 (/ shift 16) imm (tn-offset rd)))) + (emit-move-wide segment +64-bit-size+ #b00 (/ shift 16) imm (reg-offset rd)))) (define-instruction movz (segment rd imm &optional (shift 0)) (:printer move-wide ((op #b10))) (:emitter (aver (not (ldb-test (byte 4 0) shift))) - (emit-move-wide segment +64-bit-size+ #b10 (/ shift 16) imm (tn-offset rd)))) + (emit-move-wide segment +64-bit-size+ #b10 (/ shift 16) + (cond ((and (fixup-p imm) + (eq (fixup-flavor imm) :symbol-tls-index)) + (note-fixup segment :move-wide imm) + 0) + (t + imm)) + (reg-offset rd)))) (define-instruction movk (segment rd imm &optional (shift 0)) (:printer move-wide ((op #b11))) (:emitter (aver (not (ldb-test (byte 4 0) shift))) - (emit-move-wide segment +64-bit-size+ #b11 (/ shift 16) imm (tn-offset rd)))) + (emit-move-wide segment +64-bit-size+ #b11 (/ shift 16) imm (reg-offset rd)))) ;;; @@ -1015,8 +1026,8 @@ (op2 ,op2))) ,@printers (:emitter - (emit-cond-select segment +64-bit-size+ ,op (tn-offset rm) (conditional-opcode cond) - ,op2 (tn-offset rn) (tn-offset rd))))) + (emit-cond-select segment +64-bit-size+ ,op (reg-offset rm) (conditional-opcode cond) + ,op2 (reg-offset rn) (reg-offset rd))))) (def-cond-select csel 0 0) (def-cond-select csinc 0 1 @@ -1028,10 +1039,10 @@ (def-cond-select csneg 1 1) (define-instruction-macro cset (rd cond) - `(inst csinc ,rd zr-tn zr-tn (invert-condition ,cond))) + `(inst csinc ,rd zr-tn zr-tn (negate-condition ,cond))) (define-instruction-macro csetm (rd cond) - `(inst csinv ,rd zr-tn zr-tn (invert-condition ,cond))) + `(inst csinv ,rd zr-tn zr-tn (negate-condition ,cond))) ;;; (def-emitter cond-compare @@ -1052,12 +1063,12 @@ (emit-cond-compare segment +64-bit-size+ ,op (if (integerp rm-imm) rm-imm - (tn-offset rm-imm)) + (reg-offset rm-imm)) (conditional-opcode cond) (if (integerp rm-imm) 1 0) - (tn-offset rn) nzcv)))) + (reg-offset rn) nzcv)))) (def-cond-compare ccmn #b0) (def-cond-compare ccmp #b1) @@ -1083,7 +1094,7 @@ (:printer data-processing-1 ((op ,opc))) (:emitter (emit-data-processing-1 segment +64-bit-size+ - ,opc (tn-offset rn) (tn-offset rd))))) + ,opc (reg-offset rn) (reg-offset rd))))) (def-data-processing-1 rbit #b000) (def-data-processing-1 rev16 #b001) @@ -1119,8 +1130,8 @@ (:emitter (assert-same-size rd rn rm) (emit-data-processing-2 segment (reg-size rd) - (tn-offset rm) - ,opc (tn-offset rn) (tn-offset rd))))) + (reg-offset rm) + ,opc (reg-offset rn) (reg-offset rd))))) (def-data-processing-2 asrv #b001010 asr) (def-data-processing-2 lslv #b001000 lsl) @@ -1160,8 +1171,8 @@ ,@printers (:emitter (emit-data-processing-3 segment +64-bit-size+ ,op31 - (tn-offset rm) - ,o0 (tn-offset ra) (tn-offset rn) (tn-offset rd))))) + (reg-offset rm) + ,o0 (reg-offset ra) (reg-offset rn) (reg-offset rd))))) (def-data-processing-3 madd #b000 0 (:printer data-processing-3 ((op31 #b000) (o0 0) (ra 31)) @@ -1185,15 +1196,15 @@ (:printer data-processing-3 ((op31 #b010) (o0 0) (ra 31)) '(:name :tab rd ", " rn ", " rm)) (:emitter - (emit-data-processing-3 segment +64-bit-size+ #b010 (tn-offset rm) - 0 31 (tn-offset rn) (tn-offset rd)))) + (emit-data-processing-3 segment +64-bit-size+ #b010 (reg-offset rm) + 0 31 (reg-offset rn) (reg-offset rd)))) (define-instruction umulh (segment rd rn rm) (:printer data-processing-3 ((op31 #b110) (o0 0) (ra 31)) '(:name :tab rd ", " rn ", " rm)) (:emitter - (emit-data-processing-3 segment +64-bit-size+ #b110 (tn-offset rm) - 0 31 (tn-offset rn) (tn-offset rd)))) + (emit-data-processing-3 segment +64-bit-size+ #b110 (reg-offset rm) + 0 31 (reg-offset rn) (reg-offset rd)))) ;;; (define-instruction-format (ldr-str 32) @@ -1268,6 +1279,7 @@ (op4 :field (byte 1 21) :value 1) (rm :field (byte 5 16) :type 'reg) (option :fields (list (byte 3 13) (byte 1 12)) :type 'ldr-str-extend) + (op5 :field (byte 2 10) :value #b10) (ldr-str-annotation :field (byte 5 16) :type 'ldr-str-reg-annotation)) (def-emitter ldr-literal @@ -1279,11 +1291,12 @@ (rt 5 0)) (define-instruction-format (ldr-literal 32 - :default-printer '(:name :tab rt ", " label) + :default-printer '(:name :tab rt ", " label literal-annotation) :include ldr-str) (op2 :value #b011) (label :field (byte 19 5) :type 'label) - (rt :fields (list (byte 2 30) (byte 5 0)))) + (rt :fields (list (byte 2 30) (byte 5 0))) + (literal-annotation :field (byte 19 5) :type 'ldr-literal-annotation)) (defun ldr-str-offset-encodable (offset &optional (size 64)) (or (typep offset '(signed-byte 9)) @@ -1317,16 +1330,23 @@ (logior (ash (ldb (byte 1 1) opc) 2) size) size)) - (dst (tn-offset dst))) - (cond ((and (typep offset 'unsigned-byte) - (not (ldb-test (byte scale 0) offset)) - (typep (ash offset (- scale)) '(unsigned-byte 12)) + (dst (reg-offset dst))) + (cond ((and (or + (and (fixup-p offset) + (eq (fixup-flavor offset) :symbol-tls-index)) + (and (typep offset 'unsigned-byte) + (not (ldb-test (byte scale 0) offset)) + (typep (ash offset (- scale)) '(unsigned-byte 12)))) (register-p base) (eq mode :offset)) (emit-ldr-str-unsigned-imm segment size v opc - (ash offset (- scale)) - (tn-offset base) + (cond ((fixup-p offset) + (note-fixup segment :ldr-str offset) + 0) + (t + (ash offset (- scale)))) + (reg-offset base) dst)) ((and (eq mode :offset) (or (register-p offset) @@ -1343,16 +1363,15 @@ (extend (if (extend-p offset) (ecase (extend-kind offset) (:uxtw #b010) - (:lsl - #b011) + (:lsl #b011) (:sxtw #b110) (:sxtx #b111)) #b011))) (emit-ldr-str-reg segment size v opc - (tn-offset register) + (reg-offset register) extend shift - (tn-offset base) + (reg-offset base) dst))) ((and (typep offset '(signed-byte 9)) (or (register-p base) @@ -1360,7 +1379,7 @@ (emit-ldr-str-unscaled-imm segment size v opc offset index-encoding - (tn-offset base) dst)) + (reg-offset base) dst)) (t (error "Invalid STR/LDR arguments: ~s ~s" dst address))))) @@ -1409,7 +1428,7 @@ 1 0) (ash (- (label-position address) posn) -2) - (tn-offset dst)))) + (reg-offset dst)))) (emit-load-store nil 1 segment dst address)))) (def-emitter ldr-str-pair @@ -1426,7 +1445,7 @@ (define-instruction-format (ldr-str-pair 32 - :default-printer '(:name :tab rt ", " rt2 ", [" rn pair-imm-writeback) + :default-printer '(:name :tab rt ", " rt2 ", [" rn pair-imm-writeback ldr-str-annotation) :include ldr-str) (size :field (byte 2 30)) (op2 :value #b101) @@ -1436,7 +1455,8 @@ (pair-imm-writeback :fields (list (byte 2 23) (byte 2 30) (byte 7 15) (byte 1 26)) :type 'pair-imm-writeback) (rt2 :fields (list (byte 2 30) (byte 5 10)) :type 'reg-float-reg) - (rt :fields (list (byte 2 30) (byte 5 0)))) + (rt :fields (list (byte 2 30) (byte 5 0))) + (ldr-str-annotation :fields (list (byte 5 5) (byte 7 15)) :type 'ldr-str-pair-annotation)) (defun ldp-stp-offset-p (offset size) (multiple-value-bind (quot rem) (truncate offset (ecase size @@ -1480,7 +1500,7 @@ (:offset #b10)) l (ash offset (- size)) - (tn-offset rt2) (tn-offset base) (tn-offset rt1)))) + (reg-offset rt2) (reg-offset base) (reg-offset rt1)))) (define-instruction stp (segment rt1 rt2 address) (:printer ldr-str-pair ((l 0))) @@ -1514,52 +1534,204 @@ (o1 :field (byte 1 21)) (rs :field (byte 5 16) :type 'w-reg) (o0 :field (byte 1 15)) - (rt2 :field (byte 5 5) :type 'reg) + (rt2 :field (byte 5 10) :type 'reg) (rn :field (byte 5 5) :type 'x-reg-sp) (rt :field (byte 5 0) :type 'reg)) -(defmacro def-store-exclusive (name o0 o1 o2 rs &rest printers) +(defmacro def-store-exclusive (name o0 o1 o2 rs) `(define-instruction ,name (segment ,@(and rs '(rs)) rt rn) (:printer ldr-str-exclusive ((o0 ,o0) (o1 ,o1) (o2 ,o2) (l 0)) '(:name :tab ,@(and rs '(rs ", ")) rt ", [" rn "]")) - ,@printers (:emitter (emit-ldr-str-exclusive segment (logior #b10 (reg-size rt)) ,o2 0 ,o1 ,(if rs - '(tn-offset rs) + '(reg-offset rs) 31) ,o0 31 - (tn-offset rn) - (tn-offset rt))))) + (reg-offset rn) + (reg-offset rt))))) (def-store-exclusive stxr 0 0 0 t) (def-store-exclusive stlxr 1 0 0 t) (def-store-exclusive stlr 1 0 1 nil) -(defmacro def-load-exclusive (name o0 o1 o2 &rest printers) +(defmacro def-load-exclusive (name o0 o1 o2) `(define-instruction ,name (segment rt rn) (:printer ldr-str-exclusive ((o0 ,o0) (o1 ,o1) (o2 ,o2) (l 1)) '(:name :tab rt ", [" rn "]")) - ,@printers (:emitter (emit-ldr-str-exclusive segment (logior #b10 (reg-size rt)) ,o2 1 ,o1 31 ,o0 31 - (tn-offset rn) - (tn-offset rt))))) + (reg-offset rn) + (reg-offset rt))))) (def-load-exclusive ldxr 0 0 0) (def-load-exclusive ldaxr 1 0 0) (def-load-exclusive ldar 1 0 1) +(define-instruction-format (cas 32) + (size1 :field (byte 1 31) :value 1) + (size :field (byte 1 30)) + (op2 :field (byte 6 24) :value #b001000) + (o2 :field (byte 1 23) :value 1) + (l :field (byte 1 22)) + (o1 :field (byte 1 21) :value 1) + (rs :fields (list (byte 1 30) (byte 5 16)) :type 'sized-reg) + (o0 :field (byte 1 15)) + (rt2 :field (byte 5 10) :value #b11111) + (rn :field (byte 5 5) :type 'x-reg-sp) + (rt :fields (list (byte 1 30) (byte 5 0)) :type 'sized-reg)) + +(define-instruction-format (casb 32) + (size :field (byte 2 30)) + (op2 :field (byte 6 24) :value #b001000) + (o2 :field (byte 1 23) :value 1) + (l :field (byte 1 22)) + (o1 :field (byte 1 21) :value 1) + (rs :field (byte 5 16) :type 'w-reg) + (o0 :field (byte 1 15)) + (rt2 :field (byte 5 10) :value #b11111) + (rn :field (byte 5 5) :type 'x-reg-sp) + (rt :field (byte 5 0) :type 'w-reg)) + +(defmacro def-cas (name o0 l) + `(define-instruction ,name (segment rs rt rn) + (:printer cas ((o0 ,o0) (l ,l)) + '(:name :tab rs ", " rt ", [" rn "]")) + (:emitter + (emit-ldr-str-exclusive segment + (logior #b10 (reg-size rt)) + 1 + ,l + 1 + (reg-offset rs) + ,o0 + 31 + (reg-offset rn) + (reg-offset rt))))) + +(def-cas cas 0 0) +(def-cas casa 0 1) +(def-cas casal 1 1) +(def-cas casl 1 0) + +(defmacro def-casb (name size o0 l) + `(define-instruction ,name (segment rs rt rn) + (:printer casb ((size ,size) (o0 ,o0) (l ,l)) + '(:name :tab rs ", " rt ", [" rn "]")) + (:emitter + (emit-ldr-str-exclusive segment + ,size + 1 + ,l + 1 + (reg-offset rs) + ,o0 + 31 + (reg-offset rn) + (reg-offset rt))))) +(def-casb casb 0 0 0) +(def-casb casab 0 0 1) +(def-casb casalb 0 1 1) +(def-casb caslb 0 1 0) + +(def-casb cash 1 0 0) +(def-casb casah 1 0 1) +(def-casb casalh 1 1 1) +(def-casb caslh 1 1 0) + +;;; + +(def-emitter ldatomic + (size 2 30) + (#b111000 6 24) + (a 1 23) + (r 1 22) + (#b1 1 21) + (rs 5 16) + (opc 6 10) + (rn 5 5) + (rt 5 0)) + +(define-instruction-format (ldatomic 32) + (size1 :field (byte 1 31) :value #b1) + (size :field (byte 1 30)) + (op2 :field (byte 6 24) :value #b111000) + (a :field (byte 1 23)) + (r :field (byte 1 22)) + (o1 :field (byte 1 21) :value #b1) + (rs :fields (list (byte 1 30) (byte 5 16)) :type 'sized-reg) + (opc :field (byte 6 10)) + (rn :field (byte 5 5) :type 'x-reg-sp) + (rt :fields (list (byte 1 30) (byte 5 0)) :type 'sized-reg)) + +(defmacro def-ldatomic (name opc a r) + `(define-instruction ,name (segment rs rt rn) + (:printer ldatomic ((a ,a) (r ,r) (opc ,opc)) + '(:name :tab rs ", " rt ", [" rn "]")) + (:emitter + (emit-ldatomic segment + (logior #b10 (reg-size rt)) + ,a + ,r + (reg-offset rs) + ,opc + (reg-offset rn) + (reg-offset rt))))) + +(def-ldatomic ldadd 0 0 0) +(def-ldatomic ldadda 0 1 0) +(def-ldatomic ldaddal 0 1 1) + +(def-ldatomic ldeor #b001000 0 0) +(def-ldatomic ldeora #b001000 1 0) +(def-ldatomic ldeoral #b001000 1 1) + +(def-ldatomic ldset #b001100 0 0) +(def-ldatomic ldseta #b001100 1 0) +(def-ldatomic ldsetal #b001100 1 1) + +(define-instruction-format (ldaddb 32) + (size :field (byte 2 30)) + (op2 :field (byte 6 24) :value #b111000) + (a :field (byte 1 23)) + (r :field (byte 1 22)) + (o1 :field (byte 1 21) :value #b1) + (rs :field (byte 5 16) :type 'w-reg) + (opc :field (byte 6 10) :value #b0) + (rn :field (byte 5 5) :type 'x-reg-sp) + (rt :field (byte 5 0) :type 'w-reg)) + +(defmacro def-ldaddb (name size a r) + `(define-instruction ,name (segment rs rt rn) + (:printer ldaddb ((size ,size) (a ,a) (r ,r)) + '(:name :tab rs ", " rt ", [" rn "]")) + (:emitter + (emit-ldatomic segment + ,size + ,a + ,r + 0 + (reg-offset rs) + (reg-offset rn) + (reg-offset rt))))) + +(def-ldaddb ldaddb 0 0 0) +(def-ldaddb ldaddab 0 1 0) +(def-ldaddb ldaddalb 0 1 1) +(def-ldaddb ldaddh 1 0 0) +(def-ldaddb ldaddah 1 1 0) +(def-ldaddb ldaddalh 1 1 1) + ;;; (def-emitter cond-branch - (#b01010100 8 24) + (#b01010100 8 24) (imm 19 5) (#b0 1 4) (cond 4 0)) @@ -1590,7 +1762,7 @@ (not label)) (note-fixup segment :uncond-branch cond-or-label) (emit-uncond-branch segment 0 0)) - ((and (fixup-p label)) + ((fixup-p label) (note-fixup segment :cond-branch cond-or-label) (emit-cond-branch segment 0 (conditional-opcode cond-or-label))) (t @@ -1611,7 +1783,7 @@ (define-instruction bl (segment label) (:printer uncond-branch ((op 1))) (:emitter - (ecase label + (etypecase label (fixup (note-fixup segment :uncond-branch label) (emit-uncond-branch segment 1 0)) @@ -1640,19 +1812,19 @@ (define-instruction br (segment register) (:printer uncond-branch-reg ((op 0))) (:emitter - (emit-uncond-branch-reg segment 0 (tn-offset register)))) + (emit-uncond-branch-reg segment 0 (reg-offset register)))) (define-instruction blr (segment register) (:printer uncond-branch-reg ((op 1))) (:emitter - (emit-uncond-branch-reg segment 1 (tn-offset register)))) + (emit-uncond-branch-reg segment 1 (reg-offset register)))) (define-instruction ret (segment &optional (register sb-vm::lr-tn)) (:printer uncond-branch-reg ((op #b10))) (:printer uncond-branch-reg ((op #b10) (rn sb-vm::lr-offset)) '(:name)) (:emitter - (emit-uncond-branch-reg segment #b10 (tn-offset register)))) + (emit-uncond-branch-reg segment #b10 (reg-offset register)))) ;;; @@ -1681,7 +1853,7 @@ +64-bit-size+ 0 (ash (- (label-position label) posn) -2) - (tn-offset rt)))))) + (reg-offset rt)))))) (define-instruction cbnz (segment rt label) (:printer compare-branch-imm ((op 1))) @@ -1693,7 +1865,7 @@ (reg-size rt) 1 (ash (- (label-position label) posn) -2) - (tn-offset rt)))))) + (reg-offset rt)))))) (def-emitter test-branch-imm (b5 1 31) @@ -1723,7 +1895,7 @@ 0 (ldb (byte 5 0) bit) (ash (- (label-position label) posn) -2) - (tn-offset rt)))))) + (reg-offset rt)))))) (define-instruction tbnz (segment rt bit label) (:printer test-branch-imm ((op 1))) @@ -1737,10 +1909,78 @@ 1 (ldb (byte 5 0) bit) (ash (- (label-position label) posn) -2) - (tn-offset rt)))))) + (reg-offset rt)))))) + +(define-instruction tbnz* (segment rt bit label) + (:emitter + (aver (label-p label)) + (check-type bit (integer 0 63)) + (labels ((compute-delta (position &optional magic-value) + (- (label-position label + (when magic-value position) + magic-value) + position)) + (multi-instruction-emitter (segment position) + (declare (ignore position)) + (assemble (segment) + (inst tst rt (ash 1 bit)) + (inst b :ne label))) + (one-instruction-emitter (segment posn) + (emit-test-branch-imm segment + (ldb (byte 1 5) bit) + 1 + (ldb (byte 5 0) bit) + (ash (- (label-position label) posn) -2) + (reg-offset rt))) + (multi-instruction-maybe-shrink (segment chooser posn magic-value) + (declare (ignore chooser)) + (let ((delta (compute-delta posn magic-value))) + (when (typep delta '(signed-byte 14)) + (emit-back-patch segment 4 + #'one-instruction-emitter) + t)))) + (emit-chooser + segment 8 2 + #'multi-instruction-maybe-shrink + #'multi-instruction-emitter)))) + +(define-instruction tbz* (segment rt bit label) + (:emitter + (aver (label-p label)) + (check-type bit (integer 0 63)) + (labels ((compute-delta (position &optional magic-value) + (- (label-position label + (when magic-value position) + magic-value) + position)) + (multi-instruction-emitter (segment position) + (declare (ignore position)) + (assemble (segment) + (inst tst rt (ash 1 bit)) + (inst b :eq label))) + (one-instruction-emitter (segment posn) + (emit-test-branch-imm segment + (ldb (byte 1 5) bit) + 0 + (ldb (byte 5 0) bit) + (ash (- (label-position label) posn) -2) + (reg-offset rt))) + (multi-instruction-maybe-shrink (segment chooser posn magic-value) + (declare (ignore chooser)) + (let ((delta (compute-delta posn magic-value))) + (when (typep delta '(signed-byte 14)) + (emit-back-patch segment 4 + #'one-instruction-emitter) + t)))) + (emit-chooser + segment 8 2 + #'multi-instruction-maybe-shrink + #'multi-instruction-emitter)))) + + ;;; (def-emitter exception - (#b11010100 8 24) + (#b11010100 8 24) (opc 3 21) (imm 16 5) (#b000 3 2) @@ -1791,7 +2031,7 @@ op (ldb (byte 2 0) offset) (ldb (byte 19 2) offset) - (tn-offset rd)))))) + (reg-offset rd)))))) (define-instruction adr (segment rd label &optional (offset 0)) (:printer pc-relative ((op 0))) @@ -1822,24 +2062,26 @@ (#b1101101000010000 :nzcv) (#b1101101000100000 :fpcr) (#b1101101000100001 :fpsr) - (#b1101110011101000 :ccnt))) + (#b1101110011101000 :ccnt) + (#b1101111010000011 :tpidrro_el0))) (defun encode-sys-reg (reg) (ecase reg (:nzcv #b1101101000010000) (:fpcr #b1101101000100000) (:fpsr #b1101101000100001) - (:ccnt #b1101110011101000))) + (:ccnt #b1101110011101000) + (:tpidrro_el0 #b1101111010000011))) (define-instruction msr (segment sys-reg rt) (:printer sys-reg ((l 0)) '(:name :tab sys-reg ", " rt)) (:emitter - (emit-system-reg segment 0 (encode-sys-reg sys-reg) (tn-offset rt)))) + (emit-system-reg segment 0 (encode-sys-reg sys-reg) (reg-offset rt)))) (define-instruction mrs (segment rt sys-reg) (:printer sys-reg ((l 1)) '(:name :tab rt ", " sys-reg)) (:emitter - (emit-system-reg segment 1 (encode-sys-reg sys-reg) (tn-offset rt)))) + (emit-system-reg segment 1 (encode-sys-reg sys-reg) (reg-offset rt)))) ;;; @@ -1961,8 +2203,8 @@ (fp-reg-type rn) (if (eql rm 0) 0 - (tn-offset rm)) - (tn-offset rn) + (reg-offset rm)) + (reg-offset rn) ,op (if (eql rm 0) 1 @@ -2063,8 +2305,8 @@ (emit-fp-data-processing-1 segment (fp-reg-type rn) ,op - (tn-offset rn) - (tn-offset rd))))) + (reg-offset rn) + (reg-offset rd))))) (def-fp-data-processing-1 fabs #b0001) (def-fp-data-processing-1 fneg #b0010) @@ -2090,8 +2332,8 @@ (emit-fp-data-processing-1 segment (fp-reg-type rn) (logior #b100 (fp-reg-type rd)) - (tn-offset rn) - (tn-offset rd)))) + (reg-offset rn) + (reg-offset rd)))) (defmacro def-fp-data-processing-2 (name op) `(define-instruction ,name (segment rd rn rm) @@ -2105,10 +2347,10 @@ "Arguments should have the same FP storage class: ~s ~s ~s." rd rn rm) (emit-fp-data-processing-2 segment (fp-reg-type rn) - (tn-offset rm) + (reg-offset rm) ,op - (tn-offset rn) - (tn-offset rd))))) + (reg-offset rn) + (reg-offset rd))))) (def-fp-data-processing-2 fmul #b0000) (def-fp-data-processing-2 fdiv #b0001) @@ -2135,11 +2377,11 @@ (emit-fp-data-processing-3 segment (fp-reg-type rn) ,o1 - (tn-offset rm) + (reg-offset rm) ,o2 - (tn-offset ra) - (tn-offset rn) - (tn-offset rd))))) + (reg-offset ra) + (reg-offset rn) + (reg-offset rd))))) (def-fp-data-processing-3 fmadd 0 0) (def-fp-data-processing-3 fmsub 0 1) @@ -2174,8 +2416,8 @@ 'rd 'rn)) ,op - (tn-offset rn) - (tn-offset rd))))) + (reg-offset rn) + (reg-offset rd))))) (def-fp-conversion fcvtns #b00000) (def-fp-conversion fcvtnu #b00001) @@ -2203,7 +2445,7 @@ "Arguments should have the same fp storage class: ~s ~s." rd rn) (emit-fp-data-processing-1 segment (fp-reg-type rn) 0 - (tn-offset rn) (tn-offset rd))) + (reg-offset rn) (reg-offset rd))) ((and (register-p rd) (fp-register-p rn)) (let* ((type (fp-reg-type rn)) @@ -2215,7 +2457,7 @@ (if 128-p #b01111 #b110) - (tn-offset rn) (tn-offset rd)))) + (reg-offset rn) (reg-offset rd)))) ((and (register-p rn) (fp-register-p rd)) (let* ((type (fp-reg-type rd)) @@ -2227,72 +2469,8 @@ (if 128-p #b01111 #b111) - (tn-offset rn) (tn-offset rd))))))) + (reg-offset rn) (reg-offset rd))))))) -;;;; Boxed-object computation instructions (for LRA and CODE) - -;;; Compute the address of a CODE object by parsing the header of a -;;; nearby LRA or SIMPLE-FUN. - -(defun emit-compute (segment vop dest lip compute-delta) - (labels ((multi-instruction-emitter (segment position) - (let* ((delta (funcall compute-delta position)) - (negative (minusp delta)) - (delta (abs delta)) - (low (* (if negative -1 1) - (ldb (byte 19 0) delta))) - (high (ldb (byte 16 19) delta))) - ;; ADR - (emit-pc-relative segment 0 - (ldb (byte 2 0) low) - (ldb (byte 19 2) low) - (tn-offset lip)) - (assemble (segment vop) - (inst movz tmp-tn high 16) - (if negative - (inst sub dest lip (lsl tmp-tn 3)) - (inst add dest lip (lsl tmp-tn 3)))))) - (one-instruction-emitter (segment position) - (let ((delta (funcall compute-delta position))) - ;; ADR - (emit-pc-relative segment 0 - (ldb (byte 2 0) delta) - (ldb (byte 19 2) delta) - (tn-offset dest)))) - (multi-instruction-maybe-shrink (segment chooser posn magic-value) - (declare (ignore chooser)) - (when (typep (funcall compute-delta posn magic-value) - '(signed-byte 21)) - (emit-back-patch segment 4 - #'one-instruction-emitter) - t))) - (emit-chooser - segment 12 2 - #'multi-instruction-maybe-shrink - #'multi-instruction-emitter))) - -(define-instruction compute-code (segment code lip object-label) - (:vop-var vop) - (:declare (ignore object-label)) - (:emitter - (emit-compute segment vop code lip - (lambda (position &optional magic-value) - (declare (ignore magic-value)) - (- other-pointer-lowtag - position - (component-header-length)))))) - -(define-instruction compute-lra (segment dest lip lra-label) - (:vop-var vop) - (:emitter - (emit-compute segment vop dest lip - (lambda (position &optional magic-value) - (- (+ (label-position lra-label - (when magic-value position) - magic-value) - other-pointer-lowtag) - position))))) - (define-instruction load-from-label (segment dest label &optional lip) (:vop-var vop) (:emitter @@ -2310,12 +2488,12 @@ (emit-pc-relative segment 0 (ldb (byte 2 0) low) (ldb (byte 19 2) low) - (tn-offset lip)) + (reg-offset lip)) (assemble (segment vop) - (inst movz tmp-tn high 16) - (inst ldr dest (@ lip (extend tmp-tn (if negative - :sxtw - :lsl) + (inst movz dest high 16) + (inst ldr dest (@ lip (extend dest (if negative + :sxtw + :lsl) 3)))))) (one-instruction-emitter (segment position) (emit-ldr-literal segment @@ -2323,7 +2501,54 @@ 0 (ldb (byte 19 0) (ash (compute-delta position) -2)) - (tn-offset dest))) + (reg-offset dest))) + (multi-instruction-maybe-shrink (segment chooser posn magic-value) + (declare (ignore chooser)) + (let ((delta (compute-delta posn magic-value))) + (when (typep delta '(signed-byte 21)) + (emit-back-patch segment 4 + #'one-instruction-emitter) + t)))) + (if lip + (emit-chooser + segment 12 2 + #'multi-instruction-maybe-shrink + #'multi-instruction-emitter) + (emit-back-patch segment 4 #'one-instruction-emitter))))) + +(define-instruction load-constant (segment dest index &optional lip) + (:vop-var vop) + (:emitter + (labels ((compute-delta (position &optional magic-value) + (+ (- (label-position (segment-origin segment) + (when magic-value position) + magic-value) + (component-header-length) + position) + index)) + (multi-instruction-emitter (segment position) + (let* ((delta (compute-delta position)) + (negative (minusp delta)) + (low (ldb (byte 19 0) delta)) + (high (ldb (byte 16 19) delta))) + ;; ADR + (emit-pc-relative segment 0 + (ldb (byte 2 0) low) + (ldb (byte 19 2) low) + (reg-offset lip)) + (assemble (segment vop) + (inst movz dest high 16) + (inst ldr dest (@ lip (extend dest (if negative + :sxtw + :lsl) + 3)))))) + (one-instruction-emitter (segment position) + (emit-ldr-literal segment + #b01 + 0 + (ldb (byte 19 0) + (ash (compute-delta position) -2)) + (reg-offset dest))) (multi-instruction-maybe-shrink (segment chooser posn magic-value) (declare (ignore chooser)) (let ((delta (compute-delta posn magic-value))) @@ -2340,7 +2565,7 @@ ;;; SIMD (def-emitter simd-three-diff - (#b0 1 31) + (#b0 1 31) (q 1 30) (u 1 29) (#b01110 5 24) @@ -2394,10 +2619,10 @@ (decode-vector-size size) #b0 #b10 - (tn-offset rm) + (reg-offset rm) #b00011 - (tn-offset rn) - (tn-offset rd)))) + (reg-offset rn) + (reg-offset rd)))) (define-instruction-macro s-mov (rd rn &optional (size :16b)) `(let ((rd ,rd) @@ -2422,10 +2647,10 @@ (:emitter (emit-simd-extract segment (decode-vector-size size) - (tn-offset rm) + (reg-offset rm) index - (tn-offset rn) - (tn-offset rd)))) + (reg-offset rn) + (reg-offset rd)))) ;;; @@ -2464,8 +2689,8 @@ (logior (ash index1 (1+ size)) (ash 1 size)) (ash index2 size) - (tn-offset rn) - (tn-offset rd))))) + (reg-offset rn) + (reg-offset rd))))) (define-instruction-format (simd-copy-to-general 32 :include simd-copy @@ -2485,8 +2710,8 @@ (logior (ash index (1+ size)) (ash 1 size)) #b0111 - (tn-offset rn) - (tn-offset rd))))) + (reg-offset rn) + (reg-offset rd))))) (def-emitter simd-across-lanes (#b0 1 31) @@ -2543,8 +2768,8 @@ (:h 1) (:s 2)) #b11011 - (tn-offset rn) - (tn-offset rd)))) + (reg-offset rn) + (reg-offset rd)))) (define-instruction uaddlv (segment rd sized rn sizen) (:printer simd-across-lanes ((u 1) (op #b00011) @@ -2564,8 +2789,8 @@ (:s 1) (:d 2)) #b00011 - (tn-offset rn) - (tn-offset rd)))) + (reg-offset rn) + (reg-offset rd)))) (define-instruction-format (simd-two-misc 32 :default-printer '(:name :tab rd ", " rn)) @@ -2590,8 +2815,8 @@ 0 00 #b00101 - (tn-offset rn) - (tn-offset rd)))) + (reg-offset rn) + (reg-offset rd)))) ;;; Inline constants (defun canonicalize-inline-constant (constant) @@ -2707,13 +2932,347 @@ (let ((sap (code-instructions code))) (ecase kind (:absolute - (setf (sap-ref-word sap offset) value)) + (setf (sb-vm::sap-ref-word-jit sap offset) value)) (:layout-id - (setf (signed-sap-ref-32 sap offset) value)) + (setf (sb-vm::signed-sap-ref-32-jit sap offset) value)) (:cond-branch - (setf (ldb (byte 19 5) (sap-ref-32 sap offset)) + (setf (ldb (byte 19 5) (sb-vm::sap-ref-32-jit sap offset)) (ash (- value (+ (sap-int sap) offset)) -2))) (:uncond-branch - (setf (ldb (byte 26 0) (sap-ref-32 sap offset)) - (ash (- value (+ (sap-int sap) offset)) -2))))) + (setf (ldb (byte 26 0) (sb-vm::sap-ref-32-jit sap offset)) + (ash (- value (+ (sap-int sap) offset)) -2))) + (:ldr-str + (setf (ldb (byte 12 10) (sb-vm::sap-ref-32-jit sap offset)) + (ash (the (unsigned-byte #.(+ 12 word-shift)) value) + (- word-shift)))) + (:move-wide + (setf (ldb (byte 16 5) (sb-vm::sap-ref-32-jit sap offset)) + (the (unsigned-byte 16) value))))) nil) + +;;; Even though non darwin-jit arm64 targets can store directly in the +;;; code object, having two codepaths is cumbersome and, now that +;;; there's no reg-code, STRB needs to load a literal first, which +;;; isn't clearly a win compared to using a vector. +(define-instruction store-coverage-mark (segment path-index temp vector) + (:emitter + ;; No backpatch is needed to compute the offset into the code header + ;; because COMPONENT-HEADER-LENGTH is known at this point. + segment path-index temp vector + (flet ((encode-index (offset &optional word) + (cond + ((if word + (typep offset '(integer 0 255)) + (typep offset '(integer 0 4095))) + offset) + ((typep offset '(unsigned-byte 16)) + (inst* segment 'movz temp offset 0) + temp) + ((typep offset '(unsigned-byte 32)) + (inst* segment 'movz temp (ldb (byte 16 16) offset) 16) + (inst* segment 'movk temp (ldb (byte 16 0) offset) 0) + temp) + (t + (error "Bad offset ~a" offset))))) + (let* ((vector-offset (* n-word-bytes + (- (length (ir2-component-constants + (component-info *component-being-compiled*))) + 2))) + (offset (+ (* sb-vm:vector-data-offset n-word-bytes) + path-index + (- other-pointer-lowtag))) + (addr + (@ vector (encode-index offset)))) + (inst* segment 'load-constant vector vector-offset) + (inst* segment 'strb sb-vm::null-tn addr))))) + +(defun conditional-branch-p (stmt) + (and (eq (stmt-mnemonic stmt) 'b) + (= (length (stmt-operands stmt)) 2))) + +(defpattern "cmp 0 + branch" ((subs) (b)) (stmt next) + (let ((next-next (stmt-next next))) + (when (and (not (stmt-labels next)) + next-next + (not (conditional-branch-p next-next))) + (destructuring-bind (target value cmp) (stmt-operands stmt) + (when (and (eql cmp 0) + (eq target zr-tn)) + (destructuring-bind (flag label) (stmt-operands next) + (unless (eq (sb-assem::label-comment label) :merged-ifs) + (when (case flag + (:eq + (setf (stmt-mnemonic stmt) 'cbz + (stmt-operands stmt) + (list value label))) + (:ne + (setf (stmt-mnemonic stmt) 'cbnz + (stmt-operands stmt) + (list value label))) + (:ge + (setf (stmt-mnemonic stmt) 'tbz* + (stmt-operands stmt) + (list value (1- n-word-bits) label))) + (:lt + (setf (stmt-mnemonic stmt) 'tbnz* + (stmt-operands stmt) + (list value (1- n-word-bits) label)))) + (delete-stmt next) + next-next)))))))) + +(defpattern "tst one bit + branch" ((ands) (b)) (stmt next) + (let ((next-next (stmt-next next))) + (when (and (not (stmt-labels next)) + next-next + (not (conditional-branch-p next-next))) + (destructuring-bind (target value mask) (stmt-operands stmt) + (when (and (integerp mask) + (= (logcount (ldb (byte n-word-bits 0) mask)) 1) + (eq target zr-tn)) + (destructuring-bind (flag label) (stmt-operands next) + (when (case flag + (:eq + (setf (stmt-mnemonic stmt) 'tbz + (stmt-operands stmt) + (list value (1- (integer-length mask)) label))) + (:ne + (setf (stmt-mnemonic stmt) 'tbnz + (stmt-operands stmt) + (list value (1- (integer-length mask)) label)))) + (delete-stmt next) + next-next))))))) + +(defun stmt-delete-safe-p (dst1 dst2 &optional safe-translates + safe-vops) + (or (location= dst1 dst2) + (and + (not (tn-ref-next (sb-c::tn-reads dst1))) + (let ((vop (tn-ref-vop (sb-c::tn-reads dst1)))) + (and vop + (or (not safe-vops) + (memq (vop-name vop) safe-vops)) + (or (not safe-translates) + (and vop + (memq (car (sb-c::vop-parse-translate + (sb-c::vop-parse-or-lose (vop-name vop)))) + safe-translates)))))))) + +(defun tagged-mask-p (x) + (and (integerp x) + (plusp x) + (zerop (ldb (byte 1 0) x)) + (let ((untag (ash x -1))) + (= (integer-length untag) + (logcount untag))))) + +(defun untagged-mask-p (x) + (and (integerp x) + (plusp x) + (= (integer-length x) + (logcount x)))) + +;;; Tagging and applying a tagged mask can be done in one step. +(defpattern "lsl + and -> ubfiz" ((ubfm) (and)) (stmt next) + (destructuring-bind (dst1 src1 immr imms) (stmt-operands stmt) + (destructuring-bind (dst2 src2 mask) (stmt-operands next) + (when (and (location= dst1 src2) + (tagged-mask-p mask) + (= immr 63) + (= imms 62) + (stmt-delete-safe-p dst1 dst2 '(logand))) + (setf (stmt-mnemonic next) 'ubfm + (stmt-operands next) (list dst2 src1 63 (1- (logcount mask)))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +;;; Helps with SBIT +(defpattern "and + lsl -> ubfiz" ((and) (ubfm)) (stmt next) + (destructuring-bind (dst1 src1 mask) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr imms) (stmt-operands next) + (when (and (location= dst1 src2) + (untagged-mask-p mask) + (= immr 63) + (= imms 62) + (stmt-delete-safe-p dst1 dst2 nil '(sb-vm::move-from-word/fixnum))) + (setf (stmt-mnemonic next) 'ubfm + (stmt-operands next) (list dst2 src1 63 (1- (logcount mask)))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +;;; If the sign bit gets cut off it can be done with just a logical shift. +(defpattern "asr + and -> lsr" ((sbfm) (and)) (stmt next) + (destructuring-bind (dst1 src1 immr imms) (stmt-operands stmt) + (destructuring-bind (dst2 src2 mask) (stmt-operands next) + (when (and (location= dst1 src2) + (untagged-mask-p mask) + (= (integer-length mask) 63) + (= immr 1) + (= imms 63) + (stmt-delete-safe-p dst1 dst2 '(logand))) + (setf (stmt-mnemonic next) 'ubfm + (stmt-operands next) (list dst2 src1 immr imms)) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +;;; Applying a tagged mask and untagging +(defpattern "and + asr -> ubfx" ((and) (sbfm)) (stmt next) + (destructuring-bind (dst1 src1 mask) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr imms) (stmt-operands next) + (when (and (location= dst1 src2) + (tagged-mask-p mask) + (= immr 1) + (= imms 63) + (stmt-delete-safe-p dst1 dst2 nil '(sb-vm::move-to-word/fixnum))) + ;; Leave the ASR if the sign bit is left, + ;; but the AND is not needed. + (if (= (integer-length mask) 64) + (setf (stmt-operands next) (list dst2 src1 immr imms)) + (setf (stmt-mnemonic next) 'ubfm + (stmt-operands next) (list dst2 src1 1 (logcount mask)))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +(defpattern "and + and -> and" ((and) (and)) (stmt next) + (destructuring-bind (dst1 src1 mask1) (stmt-operands stmt) + (destructuring-bind (dst2 src2 mask2) (stmt-operands next) + (when + (and (location= dst1 src2) + (integerp mask1) + (integerp mask2) + (stmt-delete-safe-p dst1 dst2 '(logand))) + (let ((mask (logand mask1 mask2))) + (when (or (zerop mask) + (encode-logical-immediate mask)) + (if (zerop mask) + (setf (stmt-mnemonic next) 'orr + (stmt-operands next) (list dst2 zr-tn zr-tn)) + (setf (stmt-operands next) (list dst2 src1 mask))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))))) + +(defpattern "lsl + arith -> arith" ((ubfm) (add and orr eor)) (stmt next) + (destructuring-bind (dst1 src1 immr imms) (stmt-operands stmt) + (destructuring-bind (dst2 srcn srcm) (stmt-operands next) + (when (and (/= imms 63) + (= (1+ imms) immr) + (tn-p srcm) + (or + (location= dst1 srcm) + (location= dst1 srcn)) + (not (location= srcn srcm)) + (stmt-delete-safe-p dst1 dst2 + '(+ sb-vm::+-mod64 sb-vm::+-modfx + logand logior logxor))) + (setf (stmt-operands next) (list dst2 (if (location= dst1 srcm) + srcn + srcm) + (lsl src1 (- 63 imms)))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +(defpattern "lsl + sub -> sub" ((ubfm) (sub)) (stmt next) + (destructuring-bind (dst1 src1 immr imms) (stmt-operands stmt) + (destructuring-bind (dst2 srcn srcm) (stmt-operands next) + (when (and (/= imms 63) + (= (1+ imms) immr) + (tn-p srcm) + (location= dst1 srcm) + (not (location= srcn srcm)) + (stmt-delete-safe-p dst1 dst2 + '(- sb-vm::--mod64 sb-vm::--modfx))) + (setf (stmt-operands next) (list dst2 srcn (lsl src1 (- 63 imms)))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +(defpattern "lsl + lsl -> lsl" ((ubfm) (ubfm)) (stmt next) + (destructuring-bind (dst1 src1 immr1 imms1) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr2 imms2) (stmt-operands next) + (when (and (/= imms1 63) + (/= imms2 63) + (= (1+ imms1) immr1) + (= (1+ imms2) immr2) + (location= dst1 src2) + (stmt-delete-safe-p dst1 dst2 + '(ash + sb-vm::ash-left-mod64 + sb-vm::ash-left-modfx))) + (let ((shift (+ (- 63 imms1) + (- 63 imms2)))) + (when (<= shift 63) + (setf (stmt-operands next) (list dst2 src1 (mod (- shift) 64) (- 63 shift))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))))) + +(defpattern "asr + asr -> asr" ((sbfm) (sbfm)) (stmt next) + (destructuring-bind (dst1 src1 immr1 imms1) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr2 imms2) (stmt-operands next) + (when (and (= imms1 imms2 63) + (location= dst1 src2) + (stmt-delete-safe-p dst1 dst2 + nil '(sb-vm::move-to-word/fixnum))) + (setf (stmt-operands next) + (list dst2 src1 (min (+ immr1 immr2) 63) 63)) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +;;; An even number can be shifted right and then negated, +;;; and fixnums are even. +(defpattern "neg + asr -> neg" ((sub) (sbfm)) (stmt next) + (destructuring-bind (dst1 srcn srcm) (stmt-operands stmt) + (destructuring-bind (dst2 src2 immr imms) (stmt-operands next) + (when (and (= imms 63) + (= immr 1) + (tn-p srcm) + (sc-is srcm sb-vm::any-reg) + (location= srcn zr-tn) + (location= dst1 src2) + (stmt-delete-safe-p dst1 dst2 nil '(sb-vm::move-to-word/fixnum))) + (setf (stmt-mnemonic next) 'sub + (stmt-operands next) (list dst2 srcn (asr srcm 1))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +(defpattern "mul + sub -> msub" ((madd) (sub)) (stmt next) + (destructuring-bind (dst1 srcn1 srcm1 srca) (stmt-operands stmt) + (destructuring-bind (dst2 srcn2 srcm2) (stmt-operands next) + (when (and (tn-p srcm2) + (location= dst1 srcm2) + (location= srca zr-tn) + (not (location= srcn2 srcm2)) + (stmt-delete-safe-p dst1 dst2 + '(- sb-vm::--mod64 sb-vm::--modfx))) + (setf (stmt-mnemonic next) 'msub + (stmt-operands next) (list dst2 srcn1 srcm1 srcn2)) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) + +(defpattern "mul + add -> madd" ((madd) (add)) (stmt next) + (destructuring-bind (dst1 srcn1 srcm1 srca) (stmt-operands stmt) + (destructuring-bind (dst2 srcn2 srcm2) (stmt-operands next) + (when (and (tn-p srcm2) + (location= srca zr-tn) + (not (location= srcn2 srcm2)) + (or (location= dst1 srcm2) + (location= dst1 srcn2)) + (stmt-delete-safe-p dst1 dst2 + '(+ sb-vm::+-mod64 sb-vm::+-modfx))) + (setf (stmt-mnemonic next) 'madd + (stmt-operands next) (list dst2 + srcn1 srcm1 + (if (location= dst1 srcm2) + srcn2 + srcm2))) + (add-stmt-labels next (stmt-labels stmt)) + (delete-stmt stmt) + next)))) diff -Nru sbcl-2.1.1/src/compiler/arm64/macros.lisp sbcl-2.1.11/src/compiler/arm64/macros.lisp --- sbcl-2.1.1/src/compiler/arm64/macros.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/macros.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -102,30 +102,21 @@ (lip ,lip)) (aver (sc-is lip interior-reg)) (inst add lip function - (- (ash simple-fun-insts-offset word-shift) - fun-pointer-lowtag)) + (+ (- (ash simple-fun-insts-offset word-shift) + fun-pointer-lowtag) + 4)) (inst br lip))) -(defmacro lisp-return (function lip return-style) +(defmacro lisp-return (lip return-style) "Return to RETURN-PC." - `(let* ((function ,function) - (lip ,lip)) + `(let* ((lip ,lip)) (aver (sc-is lip interior-reg)) ;; Indicate a single-valued return by clearing the Z flag ,@(ecase return-style (:single-value '((inst cmp null-tn 0))) (:multiple-values '((inst cmp zr-tn zr-tn))) (:known)) - (inst sub lip function (- other-pointer-lowtag 8)) (inst ret lip))) - -(defmacro emit-return-pc (label) - "Emit a return-pc header word. LABEL is the label to use for this return-pc." - `(progn - (emit-alignment n-lowtag-bits) - (emit-label ,label) - (inst lra-header-word))) - ;;;; Stack TN's @@ -156,7 +147,7 @@ (once-only ((n-reg reg) (n-stack reg-or-stack)) `(sc-case ,n-reg - ((any-reg descriptor-reg) + ((any-reg descriptor-reg interior-reg) (sc-case ,n-stack ((any-reg descriptor-reg) (move ,n-reg ,n-stack)) @@ -181,37 +172,29 @@ ;;; P-A FLAG-TN is also acceptable here. #+gencgc -(defun allocation-tramp (type alloc-tn size back-label return-in-tmp lip) - (unless (eq size tmp-tn) - (inst mov tmp-tn size)) +(defun allocation-tramp (type alloc-tn size back-label lip) + (if (integerp size) + (load-immediate-word tmp-tn size) + (inst mov tmp-tn size)) (let ((asm-routine (if (eq type 'list) 'list-alloc-tramp 'alloc-tramp))) (load-inline-constant alloc-tn `(:fixup ,asm-routine :assembly-routine) lip)) (inst blr alloc-tn) - (unless return-in-tmp - (move alloc-tn tmp-tn)) (inst b back-label)) +;;; Leaves the untagged pointer in TMP-TN, +;;; Allowing it to be used with STP later. (defun allocation (type size lowtag result-tn - &key flag-tn - stack-allocate-p - (lip (if stack-allocate-p nil (missing-arg)))) + &key flag-tn + stack-allocate-p + (lip (if stack-allocate-p nil (missing-arg)))) (declare (ignorable type lip)) ;; Normal allocation to the heap. (if stack-allocate-p (assemble () - (move result-tn csp-tn) - (inst tst result-tn lowtag-mask) - (inst b :eq ALIGNED) - (inst add result-tn result-tn n-word-bytes) - ALIGNED - (inst add csp-tn result-tn (add-sub-immediate size)) - ;; :ne is from TST above, this needs to be done after the - ;; stack pointer has been stored. - (inst b :eq ALIGNED2) - (storew zr-tn result-tn -1 0) - ALIGNED2 - (when lowtag - (inst add result-tn result-tn lowtag))) + (inst add tmp-tn csp-tn lowtag-mask) + (inst and tmp-tn tmp-tn (lognot lowtag-mask)) + (inst add csp-tn tmp-tn (add-sub-immediate size result-tn)) + (inst add result-tn tmp-tn lowtag)) #-gencgc (progn (load-symbol-value flag-tn *allocation-pointer*) @@ -227,33 +210,28 @@ (load-immediate-word flag-tn boxed-region) (inst ldp result-tn flag-tn (@ flag-tn 0))) #+sb-thread - (inst ldp result-tn flag-tn (@ thread-tn (* n-word-bytes thread-alloc-region-slot))) - (setf size (add-sub-immediate size)) - (inst add result-tn result-tn size) + (inst ldp tmp-tn flag-tn (@ thread-tn (* n-word-bytes thread-boxed-tlab-slot))) + (inst add result-tn tmp-tn (add-sub-immediate size result-tn)) (inst cmp result-tn flag-tn) (inst b :hi ALLOC) #-sb-thread (inst str result-tn (@ null-tn (load-store-offset (- boxed-region nil-value)))) - #+sb-thread (storew result-tn thread-tn thread-alloc-region-slot) - ;; alloc_tramp uses tmp-tn for returning the result, - ;; save on a move when possible - (inst sub (if lowtag tmp-tn result-tn) result-tn size) + #+sb-thread (storew result-tn thread-tn thread-boxed-tlab-slot) + (emit-label BACK-FROM-ALLOC) - (when lowtag - (inst add result-tn tmp-tn lowtag)) + (inst add result-tn tmp-tn lowtag) (assemble (:elsewhere) (emit-label ALLOC) (allocation-tramp type result-tn size BACK-FROM-ALLOC - ;; see the comment above aboout alloc_tramp - lowtag lip))))) (defmacro with-fixed-allocation ((result-tn flag-tn type-code size &key (lowtag other-pointer-lowtag) stack-allocate-p - (lip (missing-arg))) + (lip (missing-arg)) + (store-type-code t)) &body body) "Do stuff to allocate an other-pointer object of fixed Size with a single word header having the specified Type-Code. The result is placed in @@ -264,27 +242,52 @@ (type-code type-code) (size size) (lowtag lowtag) (stack-allocate-p stack-allocate-p) (lip lip)) - `(pseudo-atomic (,flag-tn :sync ,type-code) + `(pseudo-atomic (,flag-tn :sync ,type-code + :elide-if ,stack-allocate-p) (allocation nil (pad-data-block ,size) ,lowtag ,result-tn :flag-tn ,flag-tn :stack-allocate-p ,stack-allocate-p :lip ,lip) (when ,type-code (load-immediate-word ,flag-tn (compute-object-header ,size ,type-code)) - (storew ,flag-tn ,result-tn 0 ,lowtag)) + ,@(and store-type-code + `((storew ,flag-tn ,result-tn 0 ,lowtag)))) ,@body))) ;;;; Error Code +;;;; BRK accepts a 16-bit immediate +;;;; Encode the error kind in the first byte. +;;;; If KIND is ERROR-TRAP, then add CODE to that first byte. +;;;; Otherwise CODE goes into the byte following BRK. +;;;; The arguments are normally encoded by ENCODE-INTERNAL-ERROR-ARGS, +;;;; except for the first argument if it's a descriptor-reg or +;;;; any-reg, then it goes into the second byte of the BRK instruction +;;;; immediate. +;;;; Otherwise that second byte is 31 (the ZR register). (defun emit-error-break (vop kind code values) (assemble () (when vop (note-this-location vop :internal-error)) - ;; Encode both kind and code as an argument to BRK - (inst brk (dpb code (byte 8 8) kind)) - ;; NARGS is implicitely assumed for invalid-arg-count - (unless (= kind invalid-arg-count-trap) - (encode-internal-error-args values) - (emit-alignment 2)))) + (cond ((= kind invalid-arg-count-trap) + ;; NARGS is implicitly assumed for invalid-arg-count + (inst brk kind) + (return-from emit-error-break)) + (t + (let ((first-value (car values))) + (inst brk (dpb (cond ((and (tn-p first-value) + (sc-is first-value descriptor-reg any-reg)) + (pop values) + (tn-offset first-value)) + (t + zr-offset)) + (byte 8 8) + (if (= kind error-trap) + (+ kind code) + kind))) + (unless (= kind error-trap) + (inst byte code))))) + (encode-internal-error-args values) + (emit-alignment 2))) (defun generate-error-code (vop error-code &rest values) "Generate-Error-Code Error-code Value* @@ -308,42 +311,42 @@ other-pointer-lowtag))))) ;;; handy macro for making sequences look atomic -(defmacro pseudo-atomic ((flag-tn &key (sync t)) &body forms) +(defmacro pseudo-atomic ((flag-tn &key elide-if (sync t)) &body forms) (declare (ignorable sync)) - #+sb-safepoint-strictly + #+sb-safepoint `(progn ,@forms (emit-safepoint)) - #-sb-safepoint-strictly + #-sb-safepoint `(progn - (without-scheduling () - #-sb-thread - (store-symbol-value csp-tn *pseudo-atomic-atomic*) - #+sb-thread - (inst str (32-bit-reg null-tn) - (@ thread-tn - (* n-word-bytes thread-pseudo-atomic-bits-slot)))) + (unless ,elide-if + (without-scheduling () + #-sb-thread + (store-symbol-value csp-tn *pseudo-atomic-atomic*) + #+sb-thread + (inst str (32-bit-reg null-tn) + (@ thread-tn + (* n-word-bytes thread-pseudo-atomic-bits-slot))))) (assemble () ,@forms) - (without-scheduling () - #-sb-thread - (progn - (store-symbol-value null-tn *pseudo-atomic-atomic*) - (load-symbol-value ,flag-tn *pseudo-atomic-interrupted*)) - #+sb-thread - (progn - (when ,sync - (inst dmb)) - (inst str (32-bit-reg zr-tn) - (@ thread-tn - (* n-word-bytes thread-pseudo-atomic-bits-slot))) - (inst ldr (32-bit-reg ,flag-tn) - (@ thread-tn - (+ (* n-word-bytes thread-pseudo-atomic-bits-slot) 4)))) - (let ((not-interrputed (gen-label))) - (inst cbz ,flag-tn not-interrputed) - (inst brk pending-interrupt-trap) - (emit-label not-interrputed)) - #+sb-safepoint - (emit-safepoint)))) + (unless ,elide-if + (without-scheduling () + #-sb-thread + (progn + (store-symbol-value null-tn *pseudo-atomic-atomic*) + (load-symbol-value ,flag-tn *pseudo-atomic-interrupted*)) + #+sb-thread + (progn + (when ,sync + (inst dmb)) + (inst str (32-bit-reg zr-tn) + (@ thread-tn + (* n-word-bytes thread-pseudo-atomic-bits-slot))) + (inst ldr (32-bit-reg ,flag-tn) + (@ thread-tn + (+ (* n-word-bytes thread-pseudo-atomic-bits-slot) 4)))) + (let ((not-interrputed (gen-label))) + (inst cbz ,flag-tn not-interrputed) + (inst brk pending-interrupt-trap) + (emit-label not-interrputed)))))) ;;;; memory accessor vop generators @@ -377,11 +380,9 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg immediate)) - (value :scs ,scs :target result)) + (value :scs (,@scs zero))) (:arg-types ,type tagged-num ,el-type) (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) (:generator 2 (sc-case index (immediate @@ -390,8 +391,7 @@ ,lowtag))))) (t (inst add lip object (lsl index (- word-shift n-fixnum-tag-bits))) - (storew value lip ,offset ,lowtag))) - (move result value)))) + (storew value lip ,offset ,lowtag)))))) (defmacro define-partial-reffer (name type size signed offset lowtag scs el-type &optional translate) @@ -443,12 +443,14 @@ (:policy :fast-safe) (:args (object :scs (descriptor-reg)) (index :scs (any-reg unsigned-reg immediate)) - (value :scs ,scs :target result)) + (value :scs ,scs + :load-if (not (and (sc-is value immediate) + (eql (tn-value value) 0))))) (:arg-types ,type tagged-num ,el-type) (:temporary (:scs (interior-reg)) lip) - (:results (result :scs ,scs)) - (:result-types ,el-type) (:generator 5 + (when (sc-is value immediate) + (setf value zr-tn)) ,@(multiple-value-bind (op shift) (ecase size (:byte @@ -475,8 +477,7 @@ (asr index (- shift)) (lsl index shift))) (inst ,op - ,value (@ lip (- (* ,offset n-word-bytes) ,lowtag))))))))) - (move result value)))) + ,value (@ lip (- (* ,offset n-word-bytes) ,lowtag)))))))))))) (defun load-inline-constant (dst value &optional lip) (destructuring-bind (size . label) (register-inline-constant value) diff -Nru sbcl-2.1.1/src/compiler/arm64/memory.lisp sbcl-2.1.11/src/compiler/arm64/memory.lisp --- sbcl-2.1.1/src/compiler/arm64/memory.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/memory.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -46,18 +46,22 @@ (:generator 5 (inst add lip object (lsl index (- word-shift n-fixnum-tag-bits))) (inst add-sub lip lip (- (* offset n-word-bytes) lowtag)) - - (inst dsb) - LOOP - ;; If this were 'ldaxr' instead of 'ldxr' maybe we wouldn't need the 'dsb' ? - (inst ldxr result lip) - (inst cmp result old-value) - (inst b :ne EXIT) - (inst stlxr tmp-tn new-value lip) - (inst cbnz (32-bit-reg tmp-tn) LOOP) - EXIT - (inst clrex) - (inst dmb))) + (cond ((member :arm-v8.1 *backend-subfeatures*) + (move result old-value) + (inst casal result new-value lip)) + (t + (assemble () + (inst dsb) + LOOP + ;; If this were 'ldaxr' instead of 'ldxr' maybe we wouldn't need the 'dsb' ? + (inst ldxr result lip) + (inst cmp result old-value) + (inst b :ne EXIT) + (inst stlxr tmp-tn new-value lip) + (inst cbnz (32-bit-reg tmp-tn) LOOP) + EXIT + (inst clrex) + (inst dmb)))))) (define-vop (set-instance-hashed) (:args (object :scs (descriptor-reg))) @@ -66,7 +70,11 @@ (:generator 5 (inst sub baseptr object instance-pointer-lowtag) LOOP - (inst ldaxr header baseptr) - (inst orr header header (ash 1 stable-hash-required-flag)) - (inst stlxr tmp-tn header baseptr) - (inst cbnz (32-bit-reg tmp-tn) LOOP))) + (cond ((member :arm-v8.1 *backend-subfeatures*) + (inst movz header (ash 1 stable-hash-required-flag)) + (inst ldset header header baseptr)) + (t + (inst ldaxr header baseptr) + (inst orr header header (ash 1 stable-hash-required-flag)) + (inst stlxr tmp-tn header baseptr) + (inst cbnz (32-bit-reg tmp-tn) LOOP))))) diff -Nru sbcl-2.1.1/src/compiler/arm64/move.lisp sbcl-2.1.11/src/compiler/arm64/move.lisp --- sbcl-2.1.1/src/compiler/arm64/move.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/move.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -12,39 +12,90 @@ (in-package "SB-VM") (defun load-immediate-word (y val) - (cond ((typep val '(unsigned-byte 16)) - (inst movz y val)) - ((typep val '(and (signed-byte 16) (integer * -1))) - (inst movn y (lognot val))) - ((typep (ldb (byte 64 0) (lognot val)) '(unsigned-byte 16)) - (inst movn y (ldb (byte 64 0) (lognot val)))) - ((encode-logical-immediate val) - (inst orr y zr-tn val)) - ((loop for i below 64 by 16 - for part = (ldb (byte 16 i) val) - for zeroed = (dpb 0 (byte 16 i) val) - thereis (cond ((encode-logical-immediate zeroed) - (inst orr y zr-tn zeroed) - (inst movk y part i) - t)))) - ((minusp val) - (loop with first = t - for i below 64 by 16 - for part = (ldb (byte 16 i) val) - unless (= part #xFFFF) - do - (if (shiftf first nil) - (inst movn y (ldb (byte 16 0) (lognot part)) i) - (inst movk y part i)))) - (t - (loop with first = t - for i below 64 by 16 - for part = (ldb (byte 16 i) val) - when (plusp part) - do - (if (shiftf first nil) - (inst movz y part i) - (inst movk y part i))))) + (let (single-mov) + (flet ((single-mov () + (setf single-mov + (or (= (loop for i below 64 by 16 + for part = (ldb (byte 16 i) val) + unless (= part #xFFFF) + count t) + 1) + (= (loop for i below 64 by 16 + for part = (ldb (byte 16 i) val) + count (plusp part)) + 1))))) + (cond ((typep val '(unsigned-byte 16)) + (inst movz y val)) + ((typep val '(and (signed-byte 16) (integer * -1))) + (inst movn y (lognot val))) + ((typep (ldb (byte 64 0) (lognot val)) '(unsigned-byte 16)) + (inst movn y (ldb (byte 64 0) (lognot val)))) + ((encode-logical-immediate val) + (inst orr y zr-tn val)) + ((and + (not (single-mov)) + (let ((descriptorp (memq (tn-offset y) descriptor-regs))) + (flet ((try (i part fill) + (let ((filled (dpb fill (byte 16 i) val))) + (cond ((and (encode-logical-immediate filled) + (not (and descriptorp + (logtest filled fixnum-tag-mask)))) + (inst orr y zr-tn filled) + (inst movk y part i) + t))))) + (loop for i below 64 by 16 + for part = (ldb (byte 16 i) val) + thereis (or (try i part #xFFFF) + (try i part 0) + (try i part + (ldb (byte 16 (mod (+ i 16) 64)) + val)))))))) + ((and (not single-mov) + (let ((a (ldb (byte 16 0) val)) + (b (ldb (byte 16 16) val)) + (c (ldb (byte 16 32) val)) + (d (ldb (byte 16 48) val))) + (let ((descriptorp (memq (tn-offset y) descriptor-regs))) + (flet ((try (part val1 hole1 val2 hole2) + (let* ((whole (dpb part (byte 16 16) part)) + (whole (dpb whole (byte 32 32) whole))) + (when (and (encode-logical-immediate whole) + (not (and descriptorp + (logtest whole fixnum-tag-mask)))) + (inst orr y zr-tn whole) + (inst movk y val1 hole1) + (inst movk y val2 hole2) + t)))) + (cond ((= a b) + (try a c 32 d 48)) + ((= a c) + (try a b 16 d 48)) + ((= a d) + (try a b 16 c 32)) + ((= b c) + (try b a 0 d 48)) + ((= b d) + (try b a 0 c 32)) + ((= c d) + (try c a 0 b 16)))))))) + ((minusp val) + (loop with first = t + for i below 64 by 16 + for part = (ldb (byte 16 i) val) + unless (= part #xFFFF) + do + (if (shiftf first nil) + (inst movn y (ldb (byte 16 0) (lognot part)) i) + (inst movk y part i)))) + (t + (loop with first = t + for i below 64 by 16 + for part = (ldb (byte 16 i) val) + when (plusp part) + do + (if (shiftf first nil) + (inst movz y part i) + (inst movk y part i))))))) y) (defun add-sub-immediate (x &optional (temp tmp-tn)) @@ -90,13 +141,7 @@ (define-move-fun (load-constant 5) (vop x y) ((constant) (descriptor-reg)) - (let ((offset (- (tn-byte-offset x) other-pointer-lowtag))) - (cond - ((ldr-str-offset-encodable offset) - (inst ldr y (@ code-tn offset))) - (t - (load-immediate-word tmp-tn offset) - (inst ldr y (@ code-tn tmp-tn)))))) + (inst load-constant y (tn-byte-offset x))) (define-move-fun (load-stack 5) (vop x y) ((control-stack) (any-reg descriptor-reg)) @@ -127,6 +172,7 @@ :scs (any-reg descriptor-reg) :load-if (not (or (location= x y) (and (sc-is x immediate) + (sc-is y control-stack) (eql (tn-value x) 0)))))) (:results (y :scs (any-reg descriptor-reg control-stack) :load-if (not (location= x y)))) @@ -149,7 +195,10 @@ ;;; frame for argument or known value passing. (define-vop (move-arg) (:args (x :target y - :scs (any-reg descriptor-reg)) + :scs (any-reg descriptor-reg) + :load-if (not (and (sc-is x immediate) + (sc-is y control-stack) + (eql (tn-value x) 0)))) (fp :scs (any-reg) :load-if (not (sc-is y any-reg descriptor-reg)))) (:results (y)) @@ -158,7 +207,11 @@ ((any-reg descriptor-reg) (move y x)) (control-stack - (store-stack-offset x fp y))))) + (store-stack-offset (if (and (sc-is x immediate) + (eql (tn-value x) 0)) + zr-tn + x) + fp y))))) ;;; (define-move-vop move-arg :move-arg (any-reg descriptor-reg) @@ -175,11 +228,11 @@ (and (tn-p tn) (sc-is tn control-stack))) (source (vop) - (tn-ref-tn (sb-c::vop-args vop))) + (tn-ref-tn (vop-args vop))) (dest (vop) - (tn-ref-tn (sb-c::vop-results vop))) + (tn-ref-tn (vop-results vop))) (load-tn (vop) - (tn-ref-load-tn (sb-c::vop-args vop))) + (tn-ref-load-tn (vop-args vop))) (suitable-offsets-p (tn1 tn2) (and (= (abs (- (tn-offset tn1) (tn-offset tn2))) @@ -287,8 +340,8 @@ '(load-stack store-stack))) (do-moves (source vop1) (source vop2) (dest vop1) (dest vop2))))) (move-arg - (let ((fp1 (tn-ref-tn (tn-ref-across (sb-c::vop-args vop1)))) - (fp2 (tn-ref-tn (tn-ref-across (sb-c::vop-args vop2)))) + (let ((fp1 (tn-ref-tn (tn-ref-across (vop-args vop1)))) + (fp2 (tn-ref-tn (tn-ref-across (vop-args vop2)))) (dest1 (dest vop1)) (dest2 (dest vop2))) (when (eq fp1 fp2) @@ -297,7 +350,7 @@ (stack-p dest2)) fp1 cfp-tn) - (tn-ref-load-tn (tn-ref-across (sb-c::vop-args vop1))))))))))) + (tn-ref-load-tn (tn-ref-across (vop-args vop1))))))))))) ;;;; ILLEGAL-MOVE @@ -355,14 +408,12 @@ (:note "integer to untagged word coercion") (:generator 4 #.(assert (= fixnum-tag-mask 1)) - (inst tbnz x 0 BIGNUM) (sc-case y (signed-reg (inst asr y x n-fixnum-tag-bits)) (unsigned-reg (inst lsr y x n-fixnum-tag-bits))) - (inst b DONE) - BIGNUM + (inst tbz x 0 DONE) (loadw y x bignum-digits-offset other-pointer-lowtag) DONE)) @@ -395,8 +446,12 @@ (move x arg) (inst adds y x x) (inst b :vc DONE) - (with-fixed-allocation (y pa-flag bignum-widetag (1+ bignum-digits-offset) :lip lip) - (storew x y bignum-digits-offset other-pointer-lowtag)) + (with-fixed-allocation (y pa-flag bignum-widetag (1+ bignum-digits-offset) :lip lip + :store-type-code nil) + ;; TMP-TN has the untagged address coming from ALLOCATION + ;; that way STP can be used on an aligned address. + ;; PA-FLAG has the widetag computed by WITH-FIXED-ALLOCATION + (storew-pair pa-flag 0 x bignum-digits-offset tmp-tn)) DONE)) (define-move-vop move-from-signed :move (signed-reg) (descriptor-reg)) @@ -439,18 +494,18 @@ (inst b :eq DONE) (with-fixed-allocation - (y pa-flag bignum-widetag (+ 2 bignum-digits-offset) :lip lip) + (y pa-flag bignum-widetag (+ 2 bignum-digits-offset) :lip lip + :store-type-code nil) ;; WITH-FIXED-ALLOCATION, when using a supplied type-code, ;; leaves PA-FLAG containing the computed header value. In our ;; case, configured for a 2-word bignum. If the sign bit in the ;; value we're boxing is CLEAR, we need to shrink the bignum by ;; one word, hence the following: - (inst tst x x) - (inst b :mi STORE) - (inst sub pa-flag pa-flag #x100) - (storew pa-flag y 0 other-pointer-lowtag) + (inst tbnz x (1- n-word-bits) STORE) + (load-immediate-word pa-flag (compute-object-header (+ 1 bignum-digits-offset) bignum-widetag)) STORE - (storew x y bignum-digits-offset other-pointer-lowtag)) + ;; See the comment in move-from-signed + (storew-pair pa-flag 0 x bignum-digits-offset tmp-tn)) DONE)) (define-move-vop move-from-unsigned :move (unsigned-reg) (descriptor-reg)) diff -Nru sbcl-2.1.1/src/compiler/arm64/nlx.lisp sbcl-2.1.11/src/compiler/arm64/nlx.lisp --- sbcl-2.1.1/src/compiler/arm64/nlx.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/nlx.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -15,7 +15,7 @@ ;;; Make a TN for the argument count passing location for a ;;; non-local entry. (defun make-nlx-entry-arg-start-location () - (make-wired-tn *fixnum-primitive-type* immediate-arg-scn r8-offset)) + (make-wired-tn *fixnum-primitive-type* immediate-arg-scn r9-offset)) ;;; Save and restore dynamic environment. (define-vop (current-stack-pointer) @@ -48,14 +48,13 @@ (:info entry-label) (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 22 (inst add block cfp-tn (add-sub-immediate (tn-byte-offset tn))) (load-tl-symbol-value temp *current-unwind-protect-block*) (storew-pair temp unwind-block-uwp-slot cfp-tn unwind-block-cfp-slot block) - (inst compute-lra temp lip entry-label) - (storew-pair code-tn unwind-block-code-slot temp unwind-block-entry-pc-slot block) + (inst adr temp entry-label) + (storew temp block unwind-block-entry-pc-slot) #+sb-thread (loadw-pair temp (/ (info :variable :wired-tls '*binding-stack-pointer*) n-word-bytes) @@ -67,9 +66,12 @@ (load-tl-symbol-value tmp-tn *current-catch-block*)) (storew-pair temp unwind-block-bsp-slot tmp-tn unwind-block-current-catch-slot block) (inst mov-sp temp nsp-tn) - (storew-pair (or (current-nfp-tn vop) zr-tn) unwind-block-nfp-slot - temp unwind-block-nsp-slot - block))) + (let ((nfp (current-nfp-tn vop))) + (if nfp + (storew-pair nfp unwind-block-nfp-slot + temp unwind-block-nsp-slot + block) + (storew temp block unwind-block-nsp-slot))))) ;;; Like Make-Unwind-Block, except that we also store in the specified tag, and ;;; link the block into the Current-Catch list. @@ -79,14 +81,13 @@ (:info entry-label) (:results (block :scs (any-reg))) (:temporary (:scs (descriptor-reg)) temp) - (:temporary (:scs (interior-reg)) lip) (:vop-var vop) (:generator 44 (inst add block cfp-tn (add-sub-immediate (tn-byte-offset tn))) (load-tl-symbol-value temp *current-unwind-protect-block*) (storew-pair temp catch-block-uwp-slot cfp-tn catch-block-cfp-slot block) - (inst compute-lra temp lip entry-label) - (storew-pair code-tn catch-block-code-slot temp catch-block-entry-pc-slot block) + (inst adr temp entry-label) + (storew temp block catch-block-entry-pc-slot) #+sb-thread (loadw-pair @@ -100,9 +101,12 @@ (storew-pair tmp-tn catch-block-previous-catch-slot tag catch-block-tag-slot block) (storew temp block catch-block-bsp-slot) (inst mov-sp temp nsp-tn) - (storew-pair (or (current-nfp-tn vop) zr-tn) unwind-block-nfp-slot - temp unwind-block-nsp-slot - block) + (let ((nfp (current-nfp-tn vop))) + (if nfp + (storew-pair nfp unwind-block-nfp-slot + temp unwind-block-nsp-slot + block) + (storew temp block unwind-block-nsp-slot))) (store-tl-symbol-value block *current-catch-block*))) ;;; Just set the current unwind-protect to UWP. This @@ -136,7 +140,7 @@ (define-vop (nlx-entry) (:args (sp) ; Note: we can't list an sc-restriction, 'cause any load vops - ; would be inserted before the LRA. + ; would be inserted before the label. (start) (count)) (:results (values :more t :from :load)) @@ -145,7 +149,7 @@ (:save-p :force-to-stack) (:vop-var vop) (:generator 30 - (emit-return-pc label) + (emit-label label) (note-this-location vop :non-local-entry) (cond ((zerop nvals)) ((= nvals 1) @@ -176,6 +180,19 @@ (store-stack-tn tn move-temp)))))))) (load-stack-tn csp-tn sp))) +(define-vop (nlx-entry-single) + (:args (sp) + (value)) + (:results (res :from :load)) + (:info label) + (:save-p :force-to-stack) + (:vop-var vop) + (:generator 30 + (emit-label label) + (note-this-location vop :non-local-entry) + (inst mov res value) + (load-stack-tn csp-tn sp))) + (define-vop (nlx-entry-multiple) (:args (top :target result) (src) @@ -191,7 +208,7 @@ (:save-p :force-to-stack) (:vop-var vop) (:generator 30 - (emit-return-pc label) + (emit-label label) (note-this-location vop :non-local-entry) ;; Setup results, and test for the zero value case. @@ -223,24 +240,33 @@ (define-vop (uwp-entry) (:info label) (:save-p :force-to-stack) - (:results (block) (start) (count)) - (:ignore block start count) (:vop-var vop) (:generator 0 - (emit-return-pc label) + (emit-label label) (note-this-location vop :non-local-entry))) -;;; Doesn't handle NSP and is disabled. +(define-vop (uwp-entry-block) + (:info label) + (:save-p :force-to-stack) + (:results (block)) + (:vop-var vop) + (:generator 0 + (emit-label label) + (note-this-location vop :non-local-entry) + ;; Get the block saved in UNWIND + (inst ldr block (@ csp-tn (* -4 n-word-bytes))))) + #+unwind-to-frame-and-call-vop (define-vop (unwind-to-frame-and-call) (:args (ofp :scs (descriptor-reg)) (uwp :scs (descriptor-reg)) (function :scs (descriptor-reg) :to :load :target saved-function) (bsp :scs (any-reg descriptor-reg)) + (nsp :scs (any-reg descriptor-reg)) (catch-block :scs (any-reg descriptor-reg))) - (:arg-types system-area-pointer system-area-pointer t t t) + (:arg-types system-area-pointer system-area-pointer t t t t) (:temporary (:sc unsigned-reg) temp) - (:temporary (:sc descriptor-reg :offset r8-offset) saved-function) + (:temporary (:sc descriptor-reg :offset r9-offset) saved-function) (:temporary (:sc unsigned-reg :offset r0-offset) block) (:temporary (:sc descriptor-reg :offset lexenv-offset) lexenv) (:temporary (:scs (interior-reg)) lip) @@ -250,7 +276,7 @@ (let ((entry-label (gen-label))) ;; Store the function into a non-stack location, since we'll be ;; unwinding the stack and destroying register contents before we - ;; use it. It turns out that R8 is preserved as part of the + ;; use it. It turns out that R9 is preserved as part of the ;; normal multiple-value handling of an unwind, so use that. (move saved-function function) @@ -265,22 +291,21 @@ (loadw temp ofp sap-pointer-slot other-pointer-lowtag) (storew temp block unwind-block-cfp-slot) (storew bsp block unwind-block-bsp-slot) + (storew nsp block unwind-block-nsp-slot) (storew catch-block block unwind-block-current-catch-slot) - ;; Don't need to save code at unwind-block-code-slot since - ;; it's not going to be used and will be overwritten after the - ;; function call - (inst compute-lra temp lip entry-label) + (inst adr temp entry-label) (storew temp block catch-block-entry-pc-slot) ;; Run any required UWPs. (load-inline-constant tmp-tn '(:fixup unwind :assembly-routine) lip) (inst br tmp-tn) - (emit-return-pc ENTRY-LABEL) + (emit-label ENTRY-LABEL) (inst mov nargs 0) (move lexenv saved-function) (loadw saved-function lexenv closure-fun-slot fun-pointer-lowtag) (lisp-jump saved-function lip)))) + diff -Nru sbcl-2.1.1/src/compiler/arm64/parms.lisp sbcl-2.1.11/src/compiler/arm64/parms.lisp --- sbcl-2.1.1/src/compiler/arm64/parms.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/parms.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -41,35 +41,6 @@ ;;; address space) (defconstant n-machine-word-bits 64) -;;; Floating-point related constants, both format descriptions and FPU -;;; control register descriptions. These don't exactly match up with -;;; what the machine manuals say because the Common Lisp standard -;;; defines floating-point values somewhat differently than the IEEE -;;; standard does. - -(defconstant float-sign-shift 31) - -(defconstant single-float-bias 126) -(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp) -(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp) -(defconstant single-float-normal-exponent-min 1) -(defconstant single-float-normal-exponent-max 254) -(defconstant single-float-hidden-bit (ash 1 23)) - -(defconstant double-float-bias 1022) -(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp) -(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp) -(defconstant double-float-normal-exponent-min 1) -(defconstant double-float-normal-exponent-max #x7FE) -(defconstant double-float-hidden-bit (ash 1 20)) - -(defconstant single-float-digits - (+ (byte-size single-float-significand-byte) 1)) - -(defconstant double-float-digits - (+ (byte-size double-float-significand-byte) 32 1)) - - (progn (defconstant float-invalid-trap-bit (ash 1 0)) (defconstant float-divide-by-zero-trap-bit (ash 1 1)) @@ -109,8 +80,12 @@ (defparameter dynamic-0-space-end #x66fff000))) #+gencgc -(!gencgc-space-setup #+(or linux openbsd) #xF0000000 #+netbsd #x2F0000000 - :dynamic-space-start #x1000000000) +(!gencgc-space-setup #+(or linux openbsd) #xF0000000 + #+darwin #x300000000 + #+netbsd #x2F0000000 + :dynamic-space-start + #-darwin #x1000000000 + #+darwin #x7003000000) (defconstant linkage-table-growth-direction :up) (defconstant linkage-table-entry-size 16) diff -Nru sbcl-2.1.1/src/compiler/arm64/pred.lisp sbcl-2.1.11/src/compiler/arm64/pred.lisp --- sbcl-2.1.1/src/compiler/arm64/pred.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/pred.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -30,19 +30,87 @@ (define-vop (branch-if) (:info dest not-p flags) (:generator 0 - (flet ((negate-condition (name) - (let ((code (logxor 1 (conditional-opcode name)))) - (aref +condition-name-vec+ code)))) (aver (null (rest flags))) (inst b (if not-p (negate-condition (first flags)) (first flags)) - dest)))) + dest))) + +(define-load-time-global *cmov-ptype-representation-vop* + (mapcan (lambda (entry) + (destructuring-bind (ptypes &optional sc vop) + entry + (mapcar (if (and vop sc) + (lambda (ptype) + (list ptype sc vop)) + #'list) + (ensure-list ptypes)))) + '((t descriptor-reg move-if/descriptor) + ((fixnum positive-fixnum) any-reg move-if/descriptor) + ((unsigned-byte-64 unsigned-byte-63) unsigned-reg move-if/word) + (signed-byte-64 signed-reg move-if/word) + (character character-reg move-if/char) + ((single-float complex-single-float + double-float complex-double-float)) + (system-area-pointer sap-reg move-if/sap)))) (defun convert-conditional-move-p (node dst-tn x-tn y-tn) - (declare (ignore node dst-tn x-tn y-tn)) - nil) + (declare (ignore node)) + (let* ((ptype (sb-c::tn-primitive-type dst-tn)) + (name (sb-c:primitive-type-name ptype)) + (param (cdr (or (assoc name *cmov-ptype-representation-vop*) + '(t descriptor-reg move-if/descriptor))))) + (when param + (destructuring-bind (representation vop) param + (let ((scn (sc-number-or-lose representation))) + (labels ((make-tn (tn) + (cond ((and (tn-sc tn) + (or + (and + (sc-is tn immediate) + (eq (tn-value tn) 0)) + (and + (sc-is tn descriptor-reg) + (eql (tn-offset tn) null-offset)))) + tn) + (t + (make-representation-tn ptype scn))))) + (values vop + (make-tn x-tn) (make-tn y-tn) + (make-tn dst-tn) + nil))))))) + + +(define-vop (move-if) + (:args (then) (else)) + (:results (res)) + (:info flags) + (:generator 0 + (let ((not-p (eq (first flags) 'not))) + (when not-p (pop flags)) + (cond ((null (rest flags)) + (inst csel res then else (if not-p + (negate-condition (car flags)) + (car flags)))) + (not-p + (dolist (flag flags) + (inst csel res else then flag))) + (t + (dolist (flag flags) + (inst csel res then else flag))))))) + +(macrolet ((def-move-if (name type reg) + `(define-vop (,name move-if) + (:args (then :scs ,reg) + (else :scs ,reg)) + (:arg-types ,type ,type) + (:results (res :scs ,reg)) + (:result-types ,type)))) + (def-move-if move-if/descriptor * (descriptor-reg any-reg zero)) + (def-move-if move-if/word (:or unsigned-num signed-num) (unsigned-reg signed-reg zero)) + (def-move-if move-if/char character (character-reg zero)) + (def-move-if move-if/sap system-area-pointer (sap-reg zero))) ;;;; Conditional VOPs: @@ -53,25 +121,24 @@ :load-if (sc-case y ((any-reg descriptor-reg)) (immediate - (not (fixnum-add-sub-immediate-p (tn-value y)))) + (not (and (integerp (tn-value y)) + (abs-add-sub-immediate-p (fixnumize (tn-value y)))))) (t t)))) - (:conditional) - (:info target not-p) + (:conditional :eq) (:policy :fast-safe) (:translate eq) (:generator 6 - (cond ((not (and (sc-is y immediate) - (eql 0 (tn-value y)))) - (inst cmp x - (sc-case y + (let ((value (sc-case y (immediate (fixnumize (tn-value y))) - (t y))) - (inst b (if not-p :ne :eq) target)) - (not-p - (inst cbnz x target)) - (t - (inst cbz x target))))) + (t y)))) + (cond ((or (not (integerp value)) + (add-sub-immediate-p value)) + (inst cmp x value)) + ((minusp value) + (inst cmn x (- value))) + (t + (inst cmn x (ldb (byte n-word-bits 0) (- value)))))))) (macrolet ((def (eq-name eql-name cost) `(define-vop (,eq-name ,eql-name) diff -Nru sbcl-2.1.1/src/compiler/arm64/sap.lisp sbcl-2.1.11/src/compiler/arm64/sap.lisp --- sbcl-2.1.1/src/compiler/arm64/sap.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/sap.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -34,8 +34,9 @@ (:results (res :scs (descriptor-reg))) (:note "SAP to pointer coercion") (:generator 20 - (with-fixed-allocation (res pa-flag sap-widetag sap-size :lip lip) - (storew sap res sap-pointer-slot other-pointer-lowtag)))) + (with-fixed-allocation (res pa-flag sap-widetag sap-size :lip lip + :store-type-code nil) + (storew-pair pa-flag 0 sap sap-pointer-slot tmp-tn)))) (define-move-vop move-from-sap :move (sap-reg) (descriptor-reg)) @@ -157,39 +158,65 @@ (:results (result :scs (,sc))) (:result-types ,type) (:generator 5 - (inst ,(case size - (:byte (if signed 'ldrsb 'ldrb)) - (:short (if signed 'ldrsh 'ldrh)) - (:word (if signed 'ldrsw 'ldr)) - (t 'ldr)) - ,(if (eq size :word) - '(32-bit-reg result) - 'result) - (@ sap offset)))) + (inst ,(case size + (:byte (if signed 'ldrsb 'ldrb)) + (:short (if signed 'ldrsh 'ldrh)) + (:word (if signed 'ldrsw 'ldr)) + (t 'ldr)) + ,(if (eq size :word) + '(32-bit-reg result) + 'result) + (@ sap offset)))) (define-vop (,set-name) (:translate ,set-name) (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg)) - (value :scs (,sc) :target result)) - (:arg-types system-area-pointer signed-num ,type) - (:results (result :scs (,sc))) - (:result-types ,type) + (:args (value :scs (,sc zero)) + (sap :scs (sap-reg)) + (offset :scs (signed-reg))) + (:arg-types ,type system-area-pointer signed-num) (:generator 5 - (inst ,(case size - (:byte 'strb) - (:short 'strh) - (t 'str)) - ,(if (eq size :word) - '(32-bit-reg value) - 'value) - (@ sap offset)) - (unless (location= result value) - ,@(case size - ((:single :double) - '((inst fmov result value))) - (t - '((inst mov result value)))))))))) + (inst ,(case size + (:byte 'strb) + (:short 'strh) + (t 'str)) + ,(if (eq size :word) + '(32-bit-reg value) + 'value) + (@ sap offset)))) + (define-vop (,(symbolicate ref-name "-C")) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg))) + (:info offset) + (:arg-types system-area-pointer (:constant (satisfies ldr-str-offset-encodable))) + (:RESULTS (result :scs (,sc))) + (:result-types ,type) + (:generator 4 + (inst ,(case size + (:byte (if signed 'ldrsb 'ldrb)) + (:short (if signed 'ldrsh 'ldrh)) + (:word (if signed 'ldrsw 'ldr)) + (t 'ldr)) + ,(if (eq size :word) + '(32-bit-reg result) + 'result) + (@ sap offset)))) + (define-vop (,(symbolicate set-name "-C")) + (:translate ,set-name) + (:policy :fast-safe) + (:args (value :scs (,sc zero)) + (sap :scs (sap-reg))) + (:info offset) + (:arg-types ,type system-area-pointer (:constant (satisfies ldr-str-offset-encodable))) + (:generator 4 + (inst ,(case size + (:byte 'strb) + (:short 'strh) + (t 'str)) + ,(if (eq size :word) + '(32-bit-reg value) + 'value) + (@ sap offset))))))) (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 unsigned-reg positive-fixnum :byte :signed nil) (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 diff -Nru sbcl-2.1.1/src/compiler/arm64/show.lisp sbcl-2.1.11/src/compiler/arm64/show.lisp --- sbcl-2.1.1/src/compiler/arm64/show.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/show.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,7 +18,7 @@ (:results (result :scs (descriptor-reg))) (:save-p t) (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) nl0) - (:temporary (:sc any-reg :offset r8-offset) cfunc) + (:temporary (:sc any-reg :offset r9-offset) cfunc) (:temporary (:scs (non-descriptor-reg)) temp) (:temporary (:scs (interior-reg)) lip) (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save) diff -Nru sbcl-2.1.1/src/compiler/arm64/subprim.lisp sbcl-2.1.11/src/compiler/arm64/subprim.lisp --- sbcl-2.1.1/src/compiler/arm64/subprim.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/subprim.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -40,7 +40,7 @@ (loadw ptr ptr cons-cdr-slot list-pointer-lowtag) (inst add count count (fixnumize 1)) - (test-type ptr temp loop nil (list-pointer-lowtag)) + (inst b loop) (emit-label not-list) diff -Nru sbcl-2.1.1/src/compiler/arm64/system.lisp sbcl-2.1.11/src/compiler/arm64/system.lisp --- sbcl-2.1.1/src/compiler/arm64/system.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/system.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -86,10 +86,8 @@ (:temporary (:sc unsigned-reg) this-id temp) (:generator 4 (let ((test-id (layout-id test-layout)) - (offset (+ (ash (+ (get-dsd-index layout sb-kernel::id-word0) - instance-slots-offset) - word-shift) - (ash (- (layout-depthoid test-layout) 2) 2) + (offset (+ (id-bits-offset) + (ash (- (wrapper-depthoid test-layout) 2) 2) (- instance-pointer-lowtag)))) (declare (ignorable test-id)) (inst ldr (32-bit-reg this-id) (@ x offset)) @@ -116,8 +114,8 @@ (:generator 6 (load-type result object (- other-pointer-lowtag)))) -(define-vop (fun-subtype) - (:translate fun-subtype) +(define-vop () + (:translate %fun-pointer-widetag) (:policy :fast-safe) (:args (function :scs (descriptor-reg))) (:results (result :scs (unsigned-reg))) @@ -138,10 +136,9 @@ (define-vop (set-header-data) (:translate set-header-data) (:policy :fast-safe) - (:args (x :scs (descriptor-reg) :target res) + (:args (x :scs (descriptor-reg)) (data :scs (any-reg immediate))) (:arg-types * positive-fixnum) - (:results (res :scs (descriptor-reg))) (:temporary (:scs (non-descriptor-reg)) t1) (:generator 6 (load-type t1 x (- other-pointer-lowtag)) @@ -150,8 +147,7 @@ (inst orr t1 t1 (lsl data (- n-widetag-bits n-fixnum-tag-bits)))) (immediate (inst orr t1 t1 (logical-mask (ash (tn-value data) n-widetag-bits))))) - (storew t1 x 0 other-pointer-lowtag) - (move res x))) + (storew t1 x 0 other-pointer-lowtag))) (define-vop (pointer-hash) (:translate pointer-hash) @@ -228,33 +224,25 @@ (inst sub ndescr ndescr (- other-pointer-lowtag fun-pointer-lowtag)) (inst add func code ndescr))) ;;; -(define-vop (symbol-info-vector) - (:policy :fast-safe) - (:translate symbol-info-vector) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (descriptor-reg))) - (:temporary (:sc unsigned-reg) temp) - (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; If RES has list-pointer-lowtag, take its CDR. If not, use it as-is. - (inst and temp res lowtag-mask) + +(defun load-symbol-dbinfo (result symbol temp) + (assemble () + (loadw result symbol symbol-info-slot other-pointer-lowtag) + ;; If RESULT has list-pointer-lowtag, take its CDR. If not, use it as-is. + (inst and temp result lowtag-mask) (inst cmp temp list-pointer-lowtag) (inst b :ne NE) - (loadw res res cons-cdr-slot list-pointer-lowtag) + (loadw result result cons-cdr-slot list-pointer-lowtag) NE)) -(define-vop (symbol-plist) +(define-vop (symbol-dbinfo) (:policy :fast-safe) - (:translate symbol-plist) + (:translate symbol-dbinfo) (:args (x :scs (descriptor-reg))) (:results (res :scs (descriptor-reg))) + (:temporary (:sc unsigned-reg) temp) (:generator 1 - (loadw res x symbol-info-slot other-pointer-lowtag) - ;; Instruction pun: (CAR x) is the same as (VECTOR-LENGTH x) - ;; so if the info slot holds a vector, this gets a fixnum- it's not a plist. - (loadw res res cons-car-slot list-pointer-lowtag) - (inst tst res fixnum-tag-mask) - (inst csel res null-tn res :eq))) + (load-symbol-dbinfo res x temp))) ;;;; other miscellaneous VOPs @@ -287,10 +275,10 @@ (:result-types system-area-pointer) (:translate current-thread-offset-sap) (:info n) - (:arg-types (:constant (satisfies ldr-str-offset-encodable))) + (:arg-types (:constant (satisfies ldr-str-word-offset-encodable))) (:policy :fast-safe) (:generator 1 - (inst ldr sap (@ thread-tn (ash n word-shift))))) + (inst ldr sap (@ thread-tn (ash n word-shift))))) (define-vop (current-thread-offset-sap) (:results (sap :scs (sap-reg))) @@ -300,7 +288,7 @@ (:arg-types signed-num) (:policy :fast-safe) (:generator 2 - (inst ldr sap (@ thread-tn (extend n :lsl word-shift)))))) + (inst ldr sap (@ thread-tn (extend n :lsl word-shift)))))) ;;; Barriers (define-vop (%compiler-barrier) @@ -330,3 +318,12 @@ (:policy :fast-safe) (:translate %data-dependency-barrier) (:generator 3)) + +(define-vop (sb-c::mark-covered) + (:info index) + (:temporary (:sc unsigned-reg) tmp) + (:temporary (:sc descriptor-reg) vector) + (:generator 4 + ;; Can't compute code-tn-relative index until the boxed header length + ;; is known. Some vops emit new boxed words via EMIT-CONSTANT. + (inst store-coverage-mark index tmp vector))) diff -Nru sbcl-2.1.1/src/compiler/arm64/target-insts.lisp sbcl-2.1.11/src/compiler/arm64/target-insts.lisp --- sbcl-2.1.1/src/compiler/arm64/target-insts.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/target-insts.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,22 +9,28 @@ (defun 32-bit-register-p (dstate) (not (logbitp 31 (current-instruction dstate)))) -(defun print-lsl-alias-name (value stream dstate) +(defun print-ubfm-alias-name (value stream dstate) (declare (ignore dstate)) (destructuring-bind (immr imms) value - (princ (if (and (/= imms 63) - (= (1+ imms) immr)) - 'lsl - 'ubfm) + (princ (cond ((and (/= imms 63) + (= (1+ imms) immr)) + 'lsl) + ((< imms immr) + 'ubfiz) + (t + 'ubfm)) stream))) -(defun print-lsl-alias (value stream dstate) +(defun print-ubfm-alias (value stream dstate) (declare (ignore dstate)) (destructuring-bind (immr imms) value - (if (and (/= imms 63) - (= (1+ imms) immr)) - (format stream "#~d" (- 63 imms)) - (format stream "#~d, #~d" immr imms)))) + (cond ((and (/= imms 63) + (= (1+ imms) immr)) + (format stream "#~d" (- 63 imms))) + ((< imms immr) + (format stream "#~d, #~d" (- 64 immr) (1+ imms))) + (t + (format stream "#~d, #~d" immr imms))))) (defun print-mem-bar-kind (value stream dstate) (declare (ignore dstate)) @@ -101,7 +107,7 @@ (defun print-test-branch-immediate (value stream dstate) (declare (ignore dstate)) (format stream "#~D" - (dpb (car value) (byte 1 5) (car value)))) + (dpb (car value) (byte 1 5) (cadr value)))) (defun decode-scaled-immediate (value) (destructuring-bind (size opc value simd) value @@ -299,7 +305,7 @@ (defun print-cond (value stream dstate) (declare (ignore dstate)) - (princ (svref sb-vm::+condition-name-vec+ value) stream)) + (princ (svref +condition-name-vec+ value) stream)) (defun use-label (value dstate) (let* ((value (if (consp value) @@ -315,26 +321,37 @@ (defun annotate-ldr-str (register offset dstate) (case register - (#.sb-vm::code-offset - (note-code-constant offset dstate)) (#.sb-vm::null-offset (let ((offset (+ sb-vm:nil-value offset))) - (maybe-note-assembler-routine offset nil dstate) - (maybe-note-static-symbol (logior offset other-pointer-lowtag) - dstate))) + (or (maybe-note-static-symbol (logior offset other-pointer-lowtag) + dstate) + (maybe-note-assembler-routine offset nil dstate)))) #+sb-thread (#.sb-vm::thread-offset (let* ((thread-slots - (load-time-value - (primitive-object-slots - (find 'sb-vm::thread *primitive-objects* - :key #'primitive-object-name)) t)) - (slot (find (ash offset (- word-shift)) thread-slots - :key #'slot-offset))) - (when slot - (note (lambda (stream) - (format stream "thread.~(~A~)" (slot-name slot))) - dstate)))))) + (load-time-value + (primitive-object-slots (primitive-object 'sb-vm::thread)) + t)) + (slot (find (ash offset (- word-shift)) thread-slots :key #'slot-offset))) + (if slot + (note (lambda (stream) + (format stream "~(~A~)" (slot-name slot))) + dstate) + (flet ((guess-symbol (predicate) + (binding* ((code-header (seg-code (dstate-segment dstate)) :exit-if-null) + (header-n-words (code-header-words code-header))) + (loop for word-num from code-constants-offset below header-n-words + for obj = (code-header-ref code-header word-num) + when (and (symbolp obj) (funcall predicate obj)) + do (return obj))))) + (let ((symbol (or (guess-symbol + (lambda (s) (= (symbol-tls-index s) offset))) + ;; static symbols aren't in the code header + (find offset +static-symbols+ + :key #'symbol-tls-index)))) + (when symbol + (note (lambda (stream) (format stream "tls: ~S" symbol)) + dstate))))))))) (defun find-value-from-previos-inst (register dstate) ;; Needs to be MOVZ REGISTER, imm, LSL #0 @@ -365,25 +382,74 @@ value) dstate)))) +(defun annotate-ldr-str-pair (value stream dstate) + (declare (ignore stream) (ignorable dstate)) + (destructuring-bind (reg offset) value + (declare (ignorable offset)) + (case reg + #+sb-thread + (#.sb-vm::thread-offset + (let* ((thread-slots + (load-time-value + (primitive-object-slots (primitive-object 'sb-vm::thread)) + t)) + (slot1 (find offset thread-slots :key #'slot-offset)) + (slot2 (find (1+ offset) thread-slots :key #'slot-offset))) + (when slot1 + (note (lambda (stream) + (if (memq (slot-name slot1) '(sb-vm::boxed-tlab + sb-vm::unboxed-tlab)) + (format stream "~(~a~).{free-pointer, end-addr}" (slot-name slot1)) + (format stream "~(~A, ~A~)" (slot-name slot1) (slot-name slot2)))) + dstate))))))) + +(defun annotate-ldr-literal (value stream dstate) + (declare (ignore stream)) + (let* ((value (* 4 value)) + (seg (dstate-segment dstate)) + (code (seg-code seg))) + (when code + (or (note-code-constant (sb-disassem::segment-offs-to-code-offs + (+ (dstate-cur-offs dstate) value) seg) + dstate) + (let ((addr (+ (dstate-cur-addr dstate) value))) + (and (sb-disassem::points-to-code-constant-p addr code) + (maybe-note-assembler-routine (sap-ref-word (int-sap addr) 0) + nil dstate))))))) + ;;;; special magic to support decoding internal-error and related traps +;;; See EMIT-ERROR-BREAK for the scheme (defun snarf-error-junk (sap offset trap-number &optional length-only) - (declare (ignore trap-number)) (let* ((inst (sap-ref-32 sap (- offset 4))) - (error-number (ldb (byte 8 13) inst)) + (error-number (cond + ((>= trap-number sb-vm:error-trap) + (prog1 + (- trap-number sb-vm:error-trap) + (setf trap-number sb-vm:error-trap))) + (t + (prog1 (sap-ref-8 sap offset) + (incf offset))))) + (first-arg (ldb (byte 8 13) inst)) (length (sb-kernel::error-length error-number)) (index offset)) (declare (type sb-sys:system-area-pointer sap) (type (unsigned-byte 8) length)) + (unless (or (= first-arg sb-vm::zr-offset) + (zerop length)) + (decf length)) (cond (length-only (loop repeat length do (sb-c:sap-read-var-integerf sap index)) (values 0 (- index offset) nil nil)) (t (collect ((sc+offsets) (lengths)) + (unless (= first-arg sb-vm::zr-offset) + (sc+offsets (make-sc+offset sb-vm:descriptor-reg-sc-number first-arg)) + (lengths 0)) (loop repeat length do - (let ((old-index index)) - (sc+offsets (sb-c:sap-read-var-integerf sap index)) - (lengths (- index old-index)))) + (let ((old-index index)) + (sc+offsets (sb-c:sap-read-var-integerf sap index)) + (lengths (- index old-index)))) (values error-number (- index offset) (sc+offsets) @@ -393,7 +459,9 @@ (declare (ignore inst chunk)) (let ((code (ldb (byte 8 5) (current-instruction dstate)))) (flet ((nt (x) (if stream (note x dstate)))) - (case code + (case (if (> code error-trap) + error-trap + code) (#.halt-trap (nt "Halt trap")) (#.pending-interrupt-trap diff -Nru sbcl-2.1.1/src/compiler/arm64/type-vops.lisp sbcl-2.1.11/src/compiler/arm64/type-vops.lisp --- sbcl-2.1.1/src/compiler/arm64/type-vops.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/type-vops.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,14 +14,16 @@ (defun %test-fixnum (value temp target not-p) (declare (ignore temp)) (assemble () - (inst tst value fixnum-tag-mask) - (inst b (if not-p :ne :eq) target))) + #.(assert (= fixnum-tag-mask 1)) + (if not-p + (inst tbnz* value 0 target) + (inst tbz* value 0 target)))) (defun %test-fixnum-immediate-and-headers (value temp target not-p immediate headers &key value-tn-ref) (let ((drop-through (gen-label))) - (inst tst value fixnum-tag-mask) - (inst b :eq (if not-p drop-through target)) + #.(assert (= fixnum-tag-mask 1)) + (inst tbz* value 0 (if not-p drop-through target)) (%test-immediate-and-headers value temp target not-p immediate headers :drop-through drop-through :value-tn-ref value-tn-ref))) @@ -29,9 +31,11 @@ (defun %test-immediate-and-headers (value temp target not-p immediate headers &key (drop-through (gen-label)) value-tn-ref) - - (inst mov temp immediate) - (inst cmp temp (extend value :uxtb)) + (cond ((= immediate single-float-widetag) + (inst cmp (32-bit-reg value) single-float-widetag)) + (t + (inst mov temp immediate) + (inst cmp temp (extend value :uxtb)))) (inst b :eq (if not-p drop-through target)) (%test-headers value temp target not-p nil headers :drop-through drop-through @@ -41,8 +45,8 @@ &key value-tn-ref) (let ((drop-through (gen-label))) (assemble () - (inst ands temp value fixnum-tag-mask) - (inst b :eq (if not-p drop-through target))) + #.(assert (= fixnum-tag-mask 1)) + (inst tbz* value 0 (if not-p drop-through target))) (%test-headers value temp target not-p nil headers :drop-through drop-through :value-tn-ref value-tn-ref))) @@ -65,71 +69,82 @@ &key (drop-through (gen-label)) value-tn-ref) (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) - (multiple-value-bind (when-true when-false) - (if not-p - (values drop-through target) - (values target drop-through)) - (assemble () - (unless (and value-tn-ref - (eq lowtag other-pointer-lowtag) - (other-pointer-tn-ref-p value-tn-ref)) - (%test-lowtag value temp when-false t lowtag)) - (load-type temp value (- lowtag)) - (do ((remaining headers (cdr remaining))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (cond - ((and (not last) (null (cddr remaining)) - (atom (cadr remaining)) - (= (logcount (logxor header (cadr remaining))) 1)) - (inst and temp temp (logical-mask - (ldb (byte 8 0) (logeqv header (cadr remaining))))) - (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining)))) - (inst b (if not-p :ne :eq) target) - (return)) - (t - (inst cmp temp header) - (if last - (inst b (if not-p :ne :eq) target) - (inst b :eq when-true))))) - (t - (let ((start (car header)) - (end (cdr header))) + (flet ((%logical-mask (x) + (cond ((encode-logical-immediate x) + x) + ;; The remaining bits of the widetag are zero, no + ;; need to mask them off. Possible to encode more + ;; values that way. + ((let ((extend (dpb x (byte 8 0) most-positive-word))) + (and (encode-logical-immediate extend) + extend))) + (t + (logical-mask x))))) + (multiple-value-bind (when-true when-false) + (if not-p + (values drop-through target) + (values target drop-through)) + (assemble () + (unless (and value-tn-ref + (eq lowtag other-pointer-lowtag) + (other-pointer-tn-ref-p value-tn-ref)) + (%test-lowtag value temp when-false t lowtag)) + (load-type temp value (- lowtag)) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) (cond - ((and last (not (= start bignum-widetag)) - (= (+ start 4) end) - (= (logcount (logxor start end)) 1)) - (inst and temp temp (logical-mask - (ldb (byte 8 0) (logeqv start end)))) - (inst cmp temp (ldb (byte 8 0) (logand start end))) - (inst b (if not-p :ne :eq) target)) ((and (not last) (null (cddr remaining)) - (= (+ start 4) end) (= (logcount (logxor start end)) 1) - (listp (cadr remaining)) - (= (+ (caadr remaining) 4) (cdadr remaining)) - (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1) - (= (logcount (logxor (caadr remaining) start)) 1)) - (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining)))) - (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining)))) + (atom (cadr remaining)) + (= (logcount (logxor header (cadr remaining))) 1)) + (inst and temp temp (%logical-mask + (ldb (byte 8 0) (logeqv header (cadr remaining))))) + (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining)))) (inst b (if not-p :ne :eq) target) (return)) (t - (unless (= start bignum-widetag) - (inst cmp temp start) - (if (= end complex-array-widetag) - (progn - (aver last) - (inst b (if not-p :lt :ge) target)) - (inst b :lt when-false))) - (unless (= end complex-array-widetag) - (inst cmp temp end) - (if last - (inst b (if not-p :gt :le) target) - (inst b :le when-true)))))))))) - (emit-label drop-through))))) + (inst cmp temp header) + (if last + (inst b (if not-p :ne :eq) target) + (inst b :eq when-true))))) + (t + (let ((start (car header)) + (end (cdr header))) + (cond + ((and last (not (= start bignum-widetag)) + (= (+ start 4) end) + (= (logcount (logxor start end)) 1)) + (inst and temp temp (%logical-mask + (ldb (byte 8 0) (logeqv start end)))) + (inst cmp temp (ldb (byte 8 0) (logand start end))) + (inst b (if not-p :ne :eq) target)) + ((and (not last) (null (cddr remaining)) + (= (+ start 4) end) (= (logcount (logxor start end)) 1) + (listp (cadr remaining)) + (= (+ (caadr remaining) 4) (cdadr remaining)) + (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1) + (= (logcount (logxor (caadr remaining) start)) 1)) + (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining)))) + (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining)))) + (inst b (if not-p :ne :eq) target) + (return)) + (t + (unless (= start bignum-widetag) + (inst cmp temp start) + (if (= end complex-array-widetag) + (progn + (aver last) + (inst b (if not-p :lt :ge) target)) + (inst b :lt when-false))) + (unless (= end complex-array-widetag) + (inst cmp temp end) + (if last + (inst b (if not-p :gt :le) target) + (inst b :le when-true)))))))))) + (emit-label drop-through)))))) ;;;; Other integer ranges. @@ -164,12 +179,13 @@ (values not-target target) (values target not-target)) (assemble () - ;; Is it a fixnum? - (move temp value) + ;; Move to a temporary and mask off the lowtag, + ;; but leave the sign bit for testing for positive fixnums. + ;; When using 32-bit registers that bit will not be visible. + (inst and temp value (logior (ash 1 (1- n-word-bits)) lowtag-mask)) (%test-fixnum temp nil fixnum nil) - - ;; If not, is it an other pointer? - (test-type value temp nope t (other-pointer-lowtag)) + (inst cmp (32-bit-reg temp) other-pointer-lowtag) + (inst b :ne nope) ;; Get the header. (loadw temp value 0 other-pointer-lowtag) ;; Is it one? @@ -190,10 +206,9 @@ ;; positive implies (unsigned-byte 64). (emit-label fixnum) - (inst cmp temp 0) (if not-p - (inst b :lt target) - (inst b :ge target)))) + (inst tbnz* temp (1- n-word-bits) target) + (inst tbz* temp (1- n-word-bits) target)))) (values)) NOT-TARGET)) @@ -208,14 +223,15 @@ n-positive-fixnum-bits))) n-positive-fixnum-bits)))) -(define-vop (fixnump/signed-byte-64 type-predicate) +(define-vop (fixnump/signed-byte-64) (:args (value :scs (signed-reg))) + (:policy :fast-safe) (:conditional :vc) (:info) (:arg-types signed-num) (:translate fixnump) (:generator 3 - (inst adds temp value value))) + (inst adds zr-tn value value))) ;;; MOD type checks (defun power-of-two-limit-p (x) @@ -237,6 +253,52 @@ (fixnumize hi)))) (inst tst value (lognot fixnum-hi))))) +(defun add-sub-immediate-p+1 (x) + (add-sub-immediate-p (1+ x))) + +(defun fixnum-add-sub-immediate-p+1 (x) + (fixnum-add-sub-immediate-p (1+ x))) + +(defun fixnum-add-sub-immediate-p/+1 (x) + (or (fixnum-add-sub-immediate-p x) + (fixnum-add-sub-immediate-p (1+ x)))) + +(define-vop (test-fixnum-mod-signed-unsigned-imm) + (:args (value :scs (unsigned-reg signed-reg))) + (:arg-types (:or unsigned-num signed-num) + (:constant (satisfies add-sub-immediate-p))) + (:translate fixnum-mod-p) + (:conditional :ls) + (:info hi) + (:policy :fast-safe) + (:generator 3 + (inst cmp value hi))) + +(define-vop (test-fixnum-mod-signed-unsigned-imm+1 test-fixnum-mod-signed-unsigned-imm) + (:arg-types (:or unsigned-num signed-num) + (:constant (satisfies add-sub-immediate-p+1))) + (:conditional :lo) + (:generator 3 + (inst cmp value (1+ hi)))) + +(define-vop (test-fixnum-mod-tagged-imm) + (:args (value :scs (any-reg))) + (:arg-types tagged-num + (:constant (satisfies fixnum-add-sub-immediate-p))) + (:translate fixnum-mod-p) + (:conditional :ls) + (:info hi) + (:policy :fast-safe) + (:generator 3 + (inst cmp value (fixnumize hi)))) + +(define-vop (test-fixnum-mod-tagged-imm+1 test-fixnum-mod-tagged-imm) + (:arg-types tagged-num + (:constant (satisfies fixnum-add-sub-immediate-p+1))) + (:conditional :lo) + (:generator 3 + (inst cmp value (fixnumize (1+ hi))))) + (define-vop (test-fixnum-mod-signed-unsigned-imm) (:args (value :scs (unsigned-reg signed-reg))) (:arg-types (:or unsigned-num signed-num) @@ -246,7 +308,14 @@ (:info hi) (:policy :fast-safe) (:generator 3 - (inst cmp value hi))) + (inst cmp value hi))) + +(define-vop (test-fixnum-mod-signed-unsigned-imm+1 test-fixnum-mod-signed-unsigned-imm) + (:arg-types (:or unsigned-num signed-num) + (:constant (satisfies add-sub-immediate-p+1))) + (:conditional :lo) + (:generator 3 + (inst cmp value (1+ hi)))) (define-vop (test-fixnum-mod-tagged-imm) (:args (value :scs (any-reg))) @@ -259,6 +328,13 @@ (:generator 3 (inst cmp value (fixnumize hi)))) +(define-vop (test-fixnum-mod-tagged-imm+1 test-fixnum-mod-tagged-imm) + (:arg-types tagged-num + (:constant (satisfies fixnum-add-sub-immediate-p+1))) + (:conditional :lo) + (:generator 3 + (inst cmp value (fixnumize (1+ hi))))) + (define-vop (test-fixnum-mod-tagged-unsigned) (:args (value :scs (any-reg unsigned-reg signed-reg))) (:arg-types (:or tagged-num unsigned-num signed-num) @@ -269,32 +345,30 @@ (:info hi) (:policy :fast-safe) (:generator 4 - (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg) - hi - (fixnumize hi)))) - (load-immediate-word temp fixnum-hi) - (inst cmp value temp)))) + (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg) + hi + (fixnumize hi)))) + (load-immediate-word temp fixnum-hi) + (inst cmp value temp)))) (define-vop (test-fixnum-mod-*-imm) (:args (value :scs (any-reg descriptor-reg))) - (:arg-types * (:constant (satisfies fixnum-add-sub-immediate-p))) + (:arg-types * (:constant (satisfies fixnum-add-sub-immediate-p/+1))) (:translate fixnum-mod-p) (:conditional) (:info target not-p hi) (:policy :fast-safe) (:generator 5 - (let ((fixnum-hi (fixnumize hi))) + (let* ((1+ (not (fixnum-add-sub-immediate-p hi))) + (fixnum-hi (fixnumize (if 1+ + (1+ hi) + hi)))) #.(assert (= fixnum-tag-mask 1)) - (cond (not-p - (inst tst value fixnum-tag-mask) - ;; TBNZ can't jump as far as B. - (inst b :ne target)) - (t - (inst tbnz value 0 skip))) + (inst tbnz* value 0 (if not-p target skip)) (inst cmp value fixnum-hi) (inst b (if not-p - :hi - :ls) + (if 1+ :hs :hi) + (if 1+ :lo :ls)) target)) skip)) @@ -308,12 +382,7 @@ (:policy :fast-safe) (:generator 6 #.(assert (= fixnum-tag-mask 1)) - (cond (not-p - (inst tst value fixnum-tag-mask) - ;; TBNZ can't jump as far as B. - (inst b :ne target)) - (t - (inst tbnz value 0 skip))) + (inst tbnz* value 0 (if not-p target skip)) (let ((condition (if not-p :hi :ls))) (load-immediate-word temp (fixnumize hi)) (inst cmp value temp) @@ -344,3 +413,11 @@ (inst b :eq is-not-cons-label) (test-type value temp target not-p (list-pointer-lowtag)) (emit-label drop-thru)))) + +(define-vop (single-float-p) + (:args (value :scs (any-reg descriptor-reg))) + (:conditional :eq) + (:policy :fast-safe) + (:translate single-float-p) + (:generator 7 + (inst cmp (32-bit-reg value) single-float-widetag))) diff -Nru sbcl-2.1.1/src/compiler/arm64/values.lisp sbcl-2.1.11/src/compiler/arm64/values.lisp --- sbcl-2.1.1/src/compiler/arm64/values.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/values.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -64,19 +64,41 @@ (count :scs (any-reg))) (:info nvals) (:temporary (:scs (descriptor-reg)) temp) + (:vop-var vop) (:generator 20 (move start csp-tn) - (inst add csp-tn csp-tn (* nvals n-word-bytes)) - (do ((val vals (tn-ref-across val)) - (i 0 (1+ i))) - ((null val)) - (let ((tn (tn-ref-tn val))) - (sc-case tn - (descriptor-reg - (storew tn start i)) - (control-stack - (load-stack-tn temp tn) - (storew temp start i))))) + (let (prev-constant) + (flet ((load-tn (tn-ref) + (let ((tn (tn-ref-tn tn-ref))) + (sc-case tn + (descriptor-reg + tn) + ((immediate constant) + (cond ((eql (tn-value tn) 0) + zr-tn) + ((or (eql prev-constant (tn-value tn)) + (progn + (setf prev-constant (tn-value tn)) + nil)) + temp) + ((sc-is tn constant) + (load-constant vop tn temp) + temp) + (t + (load-immediate vop tn temp) + temp))) + (control-stack + (setf prev-constant nil) + (load-stack-tn temp tn) + temp))))) + (cond ((= nvals 1) + (inst str (load-tn vals) (@ csp-tn n-word-bytes :post-index))) + (t + (inst add csp-tn csp-tn (* nvals n-word-bytes)) + (do ((val vals (tn-ref-across val)) + (i 0 (1+ i))) + ((null val)) + (storew (load-tn val) start i)))))) (inst mov count (fixnumize nvals)))) ;;; Push a list of values on the stack, returning Start and Count as used in diff -Nru sbcl-2.1.1/src/compiler/arm64/vm.lisp sbcl-2.1.11/src/compiler/arm64/vm.lisp --- sbcl-2.1.1/src/compiler/arm64/vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/arm64/vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,7 +11,8 @@ (in-package "SB-VM") -(defconstant-eqx +fixup-kinds+ #(:absolute :cond-branch :uncond-branch :layout-id) +(defconstant-eqx +fixup-kinds+ #(:absolute :cond-branch :uncond-branch :layout-id + :ldr-str :move-wide) #'equalp) @@ -51,40 +52,40 @@ (defreg r5 15) (defreg r6 16) (defreg r7 17) - (defreg r8 18) + (defreg #-darwin r8 #+darwin reserved 18) (defreg r9 19) + (defreg #+darwin r8 #-darwin r10 20) #+sb-thread - (defreg thread 20) + (defreg thread 21) #-sb-thread - (defreg r10 20) + (defreg r11 21) - (defreg lexenv 21) + (defreg lexenv 22) - (defreg nargs 22) - (defreg nfp 23) - (defreg ocfp 24) - (defreg cfp 25) - (defreg csp 26) - (defreg tmp 27) - (defreg null 28) - (defreg code 29) + (defreg nargs 23) + (defreg nfp 24) + (defreg ocfp 25) + (defreg cfp 26) + (defreg csp 27) + (defreg tmp 28) + (defreg null 29) (defreg lr 30) (defreg nsp 31) (defreg zr 31) (defregset system-regs - null cfp nsp lr code) + null cfp nsp lr) (defregset descriptor-regs - r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 #-sb-thread r10 lexenv) + r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 #-darwin r10 #-sb-thread r11 lexenv) (defregset non-descriptor-regs nl0 nl1 nl2 nl3 nl4 nl5 nl6 nl7 nl8 nl9 nargs nfp ocfp) (defregset boxed-regs r0 r1 r2 r3 r4 r5 r6 - r7 r8 r9 #-sb-thread r10 #+sb-thread thread lexenv code) + r7 r8 r9 #-darwin r10 #-sb-thread r11 #+sb-thread thread lexenv) ;; registers used to pass arguments ;; @@ -218,7 +219,8 @@ :alternate-scs (complex-double-stack)) (catch-block control-stack :element-size catch-block-size) - (unwind-block control-stack :element-size unwind-block-size)) + (unwind-block control-stack :element-size unwind-block-size) + (zero immediate-constant)) ;;;; Make some random tns for important registers. @@ -232,7 +234,6 @@ (defregtn null descriptor-reg) (defregtn lexenv descriptor-reg) - (defregtn code descriptor-reg) (defregtn tmp any-reg) (defregtn nargs any-reg) @@ -328,20 +329,21 @@ (%logbitp integer index)))) (t (values :default nil)))) (%ldb - (flet ((validp (type width) - (and (valid-funtype `((constant-arg (integer 1 ,(1- width))) - (constant-arg (mod ,width)) + (flet ((validp (type) + (and (valid-funtype `((constant-arg (integer 1 ,(1- n-word-bits))) + (constant-arg integer) ,type) 'unsigned-byte) (destructuring-bind (size posn integer) (sb-c::basic-combination-args node) (declare (ignore integer)) - (and (plusp (sb-c::lvar-value posn)) - (<= (+ (sb-c::lvar-value size) - (sb-c::lvar-value posn)) - width)))))) - (if (or (validp 'word (1- n-word-bits)) - (validp 'signed-word (1- n-word-bits))) + (and (plusp (sb-c:lvar-value posn)) + (or (= (sb-c:lvar-value size) 1) + (<= (+ (sb-c:lvar-value size) + (sb-c:lvar-value posn)) + n-word-bits))))))) + (if (or (validp 'word) + (validp 'signed-word)) (values :transform '(lambda (size posn integer) (%%ldb integer size posn))) (values :default nil)))) @@ -386,4 +388,6 @@ sb-arm64-asm::encode-logical-immediate sb-arm64-asm::fixnum-encode-logical-immediate bic-encode-immediate - bic-fixnum-encode-immediate)) + bic-fixnum-encode-immediate + logical-immediate-or-word-mask + sb-arm64-asm::ldr-str-offset-encodable)) diff -Nru sbcl-2.1.1/src/compiler/array-tran.lisp sbcl-2.1.11/src/compiler/array-tran.lisp --- sbcl-2.1.1/src/compiler/array-tran.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/array-tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -31,6 +31,10 @@ ;;; known supertype of the upgraded-array-element-type, if if the exact ;;; U-A-E-T is not known. (If it is NIL, the primary return value is as good ;;; as it gets.) +;;; FIXME: poorly named, it sounds like an accessor on an instance of ARRAY-TYPE, +;;; but unfortunately UPGRADED-ARRAY-ELEMENT-TYPE is a CL: symbol +;;; and %UPGRADED-ARRAY-ELEMENT-TYPE is already a thing as well. +;;; Perhaps ARRAY-IMPLIED-ELEMENT-TYPE would be less misleading? (defun array-type-upgraded-element-type (type) (typecase type ;; Note that this IF mightn't be satisfied even if the runtime @@ -109,7 +113,7 @@ ;; 2002-08-21 (values *wild-type* nil)))) -(defun array-type-declared-element-type (type) +(defun declared-array-element-type (type) (if (array-type-p type) (array-type-element-type type) *wild-type*)) @@ -127,14 +131,6 @@ :aref))) (lvar-type new-value)) -;;; Return true if ARG is NIL, or is a constant-lvar whose -;;; value is NIL, false otherwise. -(defun unsupplied-or-nil (arg) - (declare (type (or lvar null) arg)) - (or (not arg) - (and (constant-lvar-p arg) - (not (lvar-value arg))))) - (defun supplied-and-true (arg) (and arg (constant-lvar-p arg) @@ -252,12 +248,8 @@ (assert-new-value-type new-value array)))) (define hairy-data-vector-set) (define hairy-data-vector-set/check-bounds) - (define data-vector-set)) - -#+(or x86 x86-64) -(defoptimizer (data-vector-set-with-offset derive-type) ((array index offset new-value)) - (declare (ignore index offset)) - (assert-new-value-type new-value array)) + ;; DATA-VECTOR-SET is never used for value, so it doesn't need a type deriver. + ) ;;; Figure out the type of the data vector if we know the argument ;;; element type. @@ -346,11 +338,10 @@ node)) (defoptimizer (make-array-header* derive-type) ((&rest inits)) - (let* ((data-position #.(sb-vm:slot-offset - (find 'sb-vm::data (sb-vm:primitive-object-slots - (find 'array sb-vm:*primitive-objects* - :key 'sb-vm:primitive-object-name)) - :key 'sb-vm:slot-name))) + (let* ((data-position + #.(sb-vm:slot-offset + (sb-vm::primitive-object-slot (sb-vm::primitive-object 'array) + 'sb-vm::data))) (data (nth data-position inits)) (type (lvar-type data))) (when (array-type-p type) @@ -379,22 +370,27 @@ (define-source-transform vector (&rest elements) `(make-array ,(length elements) :initial-contents (list ,@elements))) -;;; Just convert it into a MAKE-ARRAY. -(deftransform make-string ((length &key - element-type - (initial-element (code-char 0)))) - ;; There's a minor edge case that is debatable: if you specify a type that is not - ;; spelled 'NIL, but equates to the empty type, then we should still return a - ;; string. MAKE-ARRAY won't do that. The safe thing to do would be to abort this - ;; transform if we don't see a constant type that is known not to be empty. - ;; But it's unnecessary hair-splitting: the old behavior was to produce a string - ;; that for all intents and purposes was unusable; the new behavior is to similarly - ;; produce an unusable object, but signal a TYPE-ERROR. - ;; The lisp hackers I surveyed would rather see the error sooner than later. - `(the simple-string (make-array (the index length) - :element-type (or element-type 'character) - ,@(when initial-element - '(:initial-element initial-element))))) +;;; Convert it into a MAKE-ARRAY if the element-type is known at compile-time. +;;; Otherwise, don't. This prevents allocating memory for a million element +;;; array of things that are not characters, and then signaling an error. +(deftransform make-string ((length &key element-type initial-element)) + (let ((elt-ctype + (cond ((not element-type) (specifier-type 'character)) + ((constant-lvar-p element-type) + (ir1-transform-specifier-type (lvar-value element-type)))))) + (when (or (not elt-ctype) + (eq elt-ctype *empty-type*) ; silly, don't do it + (contains-unknown-type-p elt-ctype)) + (give-up-ir1-transform)) + (multiple-value-bind (subtypep certainp) + (csubtypep elt-ctype (specifier-type 'character)) + (if (not certainp) (give-up-ir1-transform)) ; could be valid, don't know + (if (not subtypep) + (abort-ir1-transform "~S is not a valid :ELEMENT-TYPE for MAKE-STRING" + (lvar-value element-type)))) + `(the simple-string (make-array (the index length) + ,@(when initial-element '(:initial-element initial-element)) + :element-type ',(type-specifier elt-ctype))))) ;; Traverse the :INTIAL-CONTENTS argument to an array constructor call, ;; changing the skeleton of the data to be constructed by calls to LIST @@ -645,16 +641,115 @@ (proper-list-p sequence) (typep sequence 'sequence))) +;;; Numeric sizes which are smaller than a word, or an even multiple of a byte, +;;; do not need zero-fill because you can't produce a bogus object by reading +;;; an element. But odd sizes such as (UNSIGNED-BYTE 7) should be zero-filled. +;;; CHARACTER too because it's it's 21 bits taking up the space of 32 bits. +;;; Technically the floating-point types should probably be zero-filled because +;;; there may otherwise be trapping NaNs. +(defun should-zerofill-p (saetp &aux (spec (sb-vm:saetp-specifier saetp)) + (ctype (sb-vm:saetp-ctype saetp))) + (or (eq spec 't) + (and (numeric-type-p ctype) + (> (sb-vm:saetp-n-bits saetp) 1) + (consp spec) + (not (eql (second spec) (sb-vm:saetp-n-bits saetp)))) + ;; Actually, nothing bad seems to happen by seeing char codes over CHAR-CODE-LIMIT + ;; (and (eq spec 'character) (= bits 32)) + )) + +(declaim (inline calc-nwords-form)) +(defun calc-nwords-form (saetp const-length + &aux (n-bits (sb-vm:saetp-n-bits saetp)) + (n-pad-elements (sb-vm:saetp-n-pad-elements saetp))) + (when const-length + (return-from calc-nwords-form + (if (typep const-length 'index) + (ceiling (* (+ const-length n-pad-elements) n-bits) sb-vm:n-word-bits)))) + (let ((padded-length-form (if (zerop n-pad-elements) + '%length + `(+ %length ,n-pad-elements)))) + (cond ((= n-bits 0) 0) + ((= n-bits sb-vm:n-word-bits) padded-length-form) + ((> n-bits sb-vm:n-word-bits) ; e.g. double-float on 32-bit + (let ((n-words-per-element + (the fixnum (/ n-bits sb-vm:n-word-bits)))) ; i.e., not RATIO + #+64-bit `(* ,padded-length-form ,n-words-per-element) + #-64-bit `(the fixnum (* ,padded-length-form ,n-words-per-element)))) + (t + ;; This would have to change if we ever implement Unicode strings + ;; using 3 bytes per char (as has been suggested by xof) which makes + ;; the number of elements per word a fraction. + (let ((n-elements-per-word + (the fixnum (/ sb-vm:n-word-bits n-bits)))) ; i.e., not RATIO + ;; Use the standard algorithm for integer division rounding up, + ;; but with right-shift as the divide operator, i.e. + ;; (NTH-VALUE 0 (CEILING length n-elements-per-word)) without going + ;; through the ceiling transform, because that needs a few extra + ;; machinations to eliminate the un-needed second return value. + `(ash (+ (truly-the index ,padded-length-form) ,(1- n-elements-per-word)) + ,(- (1- (integer-length n-elements-per-word))))))))) + +;;; TODO: "initial-element #\space" for strings would be nice to handle. +(declaim (inline splat-value-p)) +(defun splat-value-p (elt-ctype initial-element default-initial-element) + (declare (ignorable elt-ctype)) + ;; If the initial-element is specified and equivalent to 0-fill + ;; then use SPLAT. + (if (constant-lvar-p initial-element) + (cond ((eql (lvar-value initial-element) default-initial-element) + 0) + ;; If SPLAT is not always a no-op - which it is for everything + ;; but x86-64 - then also use it to store NIL or unbound-marker, + ;; which is better than QUICKFILL on small arrays. Arguably it is + ;; a defect of the FILL transforms that they can't do as well. + #+x86-64 + ((eq (lvar-value initial-element) nil) + sb-vm:nil-value)) + ;; This case should not be architecture-dependent, and it isn't, + ;; except that the other architectures lack the ability + ;; to convert SPLAT via a vop. + ;; I feel that it would be a lot easier if unbound-marker manifested + ;; itself as a compile-time literal, but there's no lisp type for it + ;; and I guess we don't like that. + ;; So why not just return T from ctype-of for that object? + #+x86-64 + (when (eq elt-ctype *universal-type*) + (let ((node (lvar-uses initial-element))) + (when (and (combination-p node) + (lvar-fun-is (combination-fun node) '(%%primitive)) + (let* ((args (combination-args node)) + (arg (car args)) + (leaf (when (ref-p (lvar-uses arg)) + (ref-leaf (lvar-uses arg))))) + (and (constant-p leaf) ; (I think it has to be) + (eq (constant-value leaf) 'make-unbound-marker)))) + ;; don't need to look at the other codegen arg which is + ;; surely NIL. + :unbound))))) + ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY ;;; call which creates a vector with a known element type -- and tries ;;; to do a good job with all the different ways it can happen. (defun transform-make-array-vector (length element-type initial-element initial-contents call - &key adjustable fill-pointer) - (let* ((c-length (if (lvar-p length) - (if (constant-lvar-p length) (lvar-value length)) - length)) - (expressly-adjustable (cond ((not adjustable) nil) + &key adjustable fill-pointer + &aux c-length) + (when (and initial-contents initial-element) + (abort-ir1-transform "Both ~S and ~S specified." + :initial-contents :initial-element)) + (setq c-length (if (lvar-p length) ; some callers pass an integer per se + (if (constant-lvar-p length) (lvar-value length)) + length)) + (when (and (integerp c-length) ; 'bad-code.pure' tries to pass ((("foo"))) e.g. + fill-pointer + (csubtypep (lvar-type fill-pointer) (specifier-type 'index)) + (not (types-equal-or-intersect (lvar-type fill-pointer) + (specifier-type `(integer 0 ,c-length))))) + (abort-ir1-transform "Invalid fill-pointer ~s for a vector of length ~s." + (type-specifier (lvar-type fill-pointer)) + c-length)) + (let* ((expressly-adjustable (cond ((not adjustable) nil) ((not (constant-lvar-p adjustable)) :maybe) (t (and (lvar-value adjustable) t)))) (has-fill-pointer (cond ((not fill-pointer) nil) @@ -662,11 +757,10 @@ ((constant-lvar-p fill-pointer) (not (null (lvar-value fill-pointer)))) (t :maybe))) - (complex (cond ((or (eq expressly-adjustable t) (eq has-fill-pointer t)) t) - ((or (eq expressly-adjustable :maybe) (eq has-fill-pointer :maybe)) - ;; Deciding between complex and simple at - ;; run-time would be too much hassle - (give-up-ir1-transform)))) + (array-header-p (cond ((or (eq expressly-adjustable t) (eq has-fill-pointer t)) t) + ((or (eq expressly-adjustable :maybe) (eq has-fill-pointer :maybe)) + ;; Picking between simple and nonsimple at runtime is hard + (give-up-ir1-transform)))) (elt-spec (if element-type (lvar-value element-type) ; enforces const-ness. t)) @@ -678,57 +772,15 @@ (give-up-ir1-transform)) (t (find-saetp-by-ctype elt-ctype)))) + (n-words-form (or (calc-nwords-form saetp c-length) (give-up-ir1-transform))) (default-initial-element (sb-vm:saetp-initial-element-default saetp)) - (n-bits (sb-vm:saetp-n-bits saetp)) - (typecode (sb-vm:saetp-typecode saetp)) - (n-pad-elements (sb-vm:saetp-n-pad-elements saetp)) - (n-words-form - (cond ((not c-length) - (let ((padded-length-form (if (zerop n-pad-elements) - 'length - `(+ length ,n-pad-elements)))) - (cond - ((= n-bits 0) 0) - ((>= n-bits sb-vm:n-word-bits) - `(* ,padded-length-form - ;; i.e., not RATIO - ,(the fixnum (/ n-bits sb-vm:n-word-bits)))) - (t - (let ((n-elements-per-word (/ sb-vm:n-word-bits n-bits))) - (declare (type index n-elements-per-word)) ; i.e., not RATIO - `(ceiling (truly-the index ,padded-length-form) - ,n-elements-per-word)))))) - ((and (fixnump c-length) - (>= c-length 0)) - (ceiling (* (+ c-length n-pad-elements) n-bits) - sb-vm:n-word-bits)) - (t - (give-up-ir1-transform)))) - (data-result-spec - `(simple-array ,(sb-vm:saetp-specifier saetp) (,(or c-length '*)))) - (result-spec - (if complex - `(and (array ,(sb-vm:saetp-specifier saetp) (*)) - (not simple-array)) - `(simple-array - ,(sb-vm:saetp-specifier saetp) (,(or c-length '*))))) (data-alloc-form - `(truly-the ,data-result-spec - (allocate-vector ,typecode - ;; If LENGTH is a singleton list, - ;; we want to avoid reading it. - (the index ,(or c-length 'length)) - ,n-words-form)))) - (when (and c-length - fill-pointer - (csubtypep (lvar-type fill-pointer) (specifier-type 'index)) - (not (types-equal-or-intersect (lvar-type fill-pointer) - (specifier-type `(integer 0 ,c-length))))) - (abort-ir1-transform "Invalid fill-pointer ~s for a vector of length ~s." - (type-specifier (lvar-type fill-pointer)) - c-length)) - (labels - ((eliminate-keywords () + `(truly-the + (simple-array ,(sb-vm:saetp-specifier saetp) (,(or c-length '*))) + (allocate-vector #+ubsan ,(not (or initial-contents initial-element)) + ,(sb-vm:saetp-typecode saetp) %length nwords)))) + + (flet ((eliminate-keywords () (eliminate-keyword-args call 1 '((:element-type element-type) @@ -736,80 +788,131 @@ (:initial-element initial-element) (:adjustable adjustable) (:fill-pointer fill-pointer)))) - (allocator (type-spec &rest rest) - (let ((array - `(make-array-header* - ,(logior (if (eq has-fill-pointer t) ; can't handle :maybe - (ash sb-vm:+array-fill-pointer-p+ sb-vm:n-widetag-bits) - 0) - (or (sb-vm:saetp-complex-typecode saetp) - sb-vm:complex-vector-widetag)) - ,@rest))) - (if (eq has-fill-pointer :maybe) - `(let ((%array (truly-the ,type-spec ,array))) - (when fill-pointer - (set-header-bits %array sb-vm:+array-fill-pointer-p+)) - %array) - `(truly-the ,type-spec ,array)))) - (with-alloc-form (&optional data-wrapper) - (cond (complex - (let* ((constant-fill-pointer-p (constant-lvar-p fill-pointer)) - (fill-pointer-value (and constant-fill-pointer-p - (lvar-value fill-pointer))) - (length-expr - (cond ((eq fill-pointer-value t) '%length) - (fill-pointer-value) - ((and fill-pointer (not constant-fill-pointer-p)) - `(cond ((or (eq fill-pointer t) (null fill-pointer)) - %length) - ((> fill-pointer %length) - (error "Invalid fill-pointer ~a" fill-pointer)) - (t fill-pointer))) - (t '%length)))) - `(let ((%length (the index ,(or c-length 'length)))) - ,(allocator result-spec - length-expr ; fill-pointer - '%length ; elements - `(let ((data ,data-alloc-form)) ; data - ,(or data-wrapper 'data)) - 0 ; displacement - nil ; displaced-p - nil ; displaced-from - '%length)))) ; dimensions - (data-wrapper - (subst data-alloc-form 'data data-wrapper)) - (t - data-alloc-form)))) - (cond ((and initial-element initial-contents) - (abort-ir1-transform "Both ~S and ~S specified." - :initial-contents :initial-element)) - ;; Case (1) - ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a - ;; constant LENGTH. - ((and initial-contents c-length - (lvar-matches initial-contents - ;; FIXME: probably don't need all 4 of these now? - :fun-names '(list vector - sb-impl::|List| sb-impl::|Vector|) - :arg-count c-length)) - (let ((parameters (eliminate-keywords)) - (elt-vars (make-gensym-list c-length)) - (lambda-list '(length))) - (splice-fun-args initial-contents :any c-length) - (dolist (p parameters) - (setf lambda-list - (append lambda-list - (if (eq p 'initial-contents) - elt-vars - (list p))))) + (wrap (underlying) + `(let* ((%length ,(or c-length '(the index length))) + (nwords ,n-words-form)) + (declare (flushable sb-vm::splat)) + ,(if (not array-header-p) + underlying ; was already cast using TRULY-THE + (let* ((constant-fill-pointer-p (and fill-pointer + (constant-lvar-p fill-pointer))) + (fill-pointer-value (and constant-fill-pointer-p + (lvar-value fill-pointer))) + (length-expr + (cond ((eq fill-pointer-value t) '%length) + (fill-pointer-value) + ((and fill-pointer (not constant-fill-pointer-p)) + `(cond ((or (eq fill-pointer t) (null fill-pointer)) + %length) + ((> fill-pointer %length) + (error "Invalid fill-pointer ~a" fill-pointer)) + (t fill-pointer))) + (t '%length))) + ;; MAKE-ARRAY-HEADER* demands a constant, not an expression + ;; for the the header word. + (header-bits + (logior (if (eq has-fill-pointer t) ; (i.e. can't handle :maybe) + (ash sb-vm:+array-fill-pointer-p+ sb-vm:array-flags-position) + 0) + (or (sb-vm:saetp-complex-typecode saetp) + sb-vm:complex-vector-widetag))) + (array-header + `(truly-the + ;; A constant length must not be part of the result type. + (and (array ,(sb-vm:saetp-specifier saetp) (*)) + (not simple-array)) + (make-array-header* ,header-bits + ,length-expr ; fill-pointer + %length ; total number of elements + ,underlying + 0 ; displacement + nil ; displaced-p + nil ; displaced-from + %length)))) ; dimensions + (if (eq has-fill-pointer :maybe) + `(let ((%array ,array-header)) + (when fill-pointer + (logior-array-flags %array sb-vm:+array-fill-pointer-p+)) + %array) + array-header)))))) + (cond ;; Case (1) - :INITIAL-ELEMENT + (initial-element + ;; If the specified initial element is equivalent to zero-filling, + ;; then use SPLAT, which is elidable for heap allocations. + ;; Also pick off (at least 2) other common cases for SPLAT: NIL and + ;; unbound-marker. The latter helps PCL ctors not to call FILL. + (let ((splat (splat-value-p elt-ctype initial-element + default-initial-element)) + (init (if (constant-lvar-p initial-element) + (list 'quote (lvar-value initial-element)) + 'initial-element)) + (lambda-list `(length ,@(eliminate-keywords)))) `(lambda ,lambda-list - (declare (type ,elt-spec ,@elt-vars) - (ignorable ,@lambda-list)) - ,(with-alloc-form - `(initialize-vector data ,@elt-vars))))) - ;; Case (2) - ;; constant :INITIAL-CONTENTS and LENGTH - ((and initial-contents c-length + (declare (ignorable ,@lambda-list)) + ,(wrap (cond ((not splat) + `(quickfill ,data-alloc-form + ,(if (eq elt-spec t) init + `(the ,elt-spec ,init)))) + ((or (eq splat :unbound) + (and (constant-lvar-p initial-element) + (testable-type-p elt-ctype) + (ctypep (lvar-value initial-element) elt-ctype))) + ;; all good + `(sb-vm::splat ,data-alloc-form nwords ,splat)) + (t + ;; uncertain if initial-element is type-correct + `(progn (the ,elt-spec ,init) ; check en passant + (sb-vm::splat ,data-alloc-form nwords + ,splat)))))))) + + ;; Case (2) - neither element nor contents specified. + ((not initial-contents) + ;; The implicit default is to zero-fill, but DX arrays could be initialized + ;; with the unbound-marker. Either way it's worth a style-warning + ;; if it looks wrong for the specified element type. + ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE '(INTEGER 1 5)) + ;; ANSI's definition of MAKE-ARRAY says "If INITIAL-ELEMENT is not supplied, + ;; the consequences of later reading an uninitialized element of new-array + ;; are undefined," so this could be legal code as long as the user plans to + ;; write before he reads, and if he doesn't we're free to do anything we like. + ;; But in case the user doesn't know to write elements before he reads elements + ;; (or to read manuals before he writes code:-), we'll signal a STYLE-WARNING + ;; in case he didn't realize this. + #-sb-xc-host + (when (and ;; Warn only if any array elements are initialized using the default. + (not (eql c-length 0)) + ;; If it's coming from the source transform, + ;; then fill-array means it was supplied initial-contents + (not (lvar-matches-calls (combination-lvar call) + '(make-array-header* fill-array))) + (testable-type-p elt-ctype) + ;; I really don't want to style-warn about + ;; (MAKE-ARRAY 1 :ELEMENT-TYPE 'STANDARD-CHAR) even though technically + ;; the default fill of #\nul is wrong because it must match the specified + ;; element type, not the upgraded array type, and #\nul isn't standard. + (not (ctypep default-initial-element + (if (and (eq elt-spec 'standard-char) (not initial-element)) + (sb-vm:saetp-ctype saetp) + elt-ctype)))) + (compiler-style-warn 'initial-element-mismatch-style-warning + :format-control "The default initial element ~S is not a ~S." + :format-arguments (list default-initial-element elt-spec))) + (let ((lambda-list `(length ,@(eliminate-keywords)))) + `(lambda ,lambda-list + (declare (ignorable ,@lambda-list)) + ,(wrap (cond ((eql (sb-vm:saetp-typecode saetp) sb-vm:simple-vector-widetag) + `(sb-vm::splat ,data-alloc-form nwords + ;; uninitialized reads are trapped regardless of safety + ;; if #+ubsan + #+ubsan :trap + #-ubsan 0)) + (t + ;; otherwise, reading an element can't cause an invalid bit pattern + ;; to be observed, but the bits could be random. + data-alloc-form)))))) + + ;; Case (3) - constant :INITIAL-CONTENTS and LENGTH + ((and c-length (constant-lvar-p initial-contents) ;; As a practical matter, the initial-contents should not be ;; too long, otherwise the compiler seems to spend forever @@ -827,14 +930,39 @@ (let ((lambda-list `(length ,@(eliminate-keywords)))) `(lambda ,lambda-list (declare (ignorable ,@lambda-list)) - ,(with-alloc-form - `(initialize-vector data - ,@(map 'list (lambda (elt) - `(the ,elt-spec ',elt)) - contents))))))) - ;; Case (3) - ;; any other :INITIAL-CONTENTS - (initial-contents + ,(wrap `(initialize-vector + ,data-alloc-form + ,@(map 'list + (if (eq elt-spec t) ; THE would be pure noise + (lambda (elt) `',elt) + (lambda (elt) `(the ,elt-spec ',elt))) + contents))))))) + + ;; Case (4) + ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with constant LENGTH. + ((and c-length + (lvar-matches initial-contents + ;; FIXME: probably don't need all 4 of these now? + :fun-names '(list vector + sb-impl::|List| sb-impl::|Vector|) + :arg-count c-length)) + (let ((parameters (eliminate-keywords)) + (elt-vars (make-gensym-list c-length)) + (lambda-list '(length))) + (splice-fun-args initial-contents :any c-length) + (dolist (p parameters) + (setf lambda-list + (append lambda-list + (if (eq p 'initial-contents) + elt-vars + (list p))))) + `(lambda ,lambda-list + (declare ,@(unless (eq elt-spec t) `((type ,elt-spec ,@elt-vars))) + (ignorable ,@lambda-list)) + ,(wrap `(initialize-vector ,data-alloc-form ,@elt-vars))))) + + ;; Case (5) - :INITIAL-CONTENTS and indeterminate length + (t (let ((lambda-list `(length ,@(eliminate-keywords)))) `(lambda ,lambda-list (declare (ignorable ,@lambda-list)) @@ -842,79 +970,19 @@ (error "~S has ~D elements, vector length is ~D." :initial-contents (length initial-contents) ,(or c-length 'length))) - ,(with-alloc-form - `(replace data initial-contents))))) - ;; Case (4) - ;; :INITIAL-ELEMENT, not EQL to the default - ((and initial-element - (or (not (constant-lvar-p initial-element)) - (not (eql default-initial-element (lvar-value initial-element))))) - (let ((lambda-list `(length ,@(eliminate-keywords))) - (init (if (constant-lvar-p initial-element) - (list 'quote (lvar-value initial-element)) - 'initial-element))) - `(lambda ,lambda-list - (declare (ignorable ,@lambda-list)) - ,(with-alloc-form - `(fill data (the ,elt-spec ,init)))))) - ;; Case (5) - ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the - ;; default - (t - #-sb-xc-host - (and (and (testable-type-p elt-ctype) - (neq elt-ctype *empty-type*) - ;; An explicitly passed :INITIAL-ELEMENT must match the specified - ;; element-type, not the upgraded type. But I don't want to style-warn - ;; about (make-array 1 :element-type 'standard-char) with an implicit - ;; initial element of #\nul. However, generally comparing against the - ;; upgraded type for any implicit initializer would never warn about - ;; things like (make-array 1 :element-type 'string). - (not (ctypep default-initial-element - (if (and (eq elt-spec 'standard-char) (not initial-element)) - (sb-vm:saetp-ctype saetp) - elt-ctype)))) - ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE - ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If - ;; INITIAL-ELEMENT is not supplied, the consequences of later - ;; reading an uninitialized element of new-array are undefined," - ;; so this could be legal code as long as the user plans to - ;; write before he reads, and if he doesn't we're free to do - ;; anything we like. But in case the user doesn't know to write - ;; elements before he reads elements (or to read manuals before - ;; he writes code:-), we'll signal a STYLE-WARNING in case he - ;; didn't realize this. - (cond - (initial-element - (compiler-warn 'array-initial-element-mismatch - :format-control "~S ~S is not a ~S" - :format-arguments - (list :initial-element default-initial-element elt-spec))) - ;; For the default initial element, only warn if - ;; any array elements are initialized using it. - ((and (not (eql c-length 0)) - ;; If it's coming from the source transform, - ;; then fill-array means it was supplied initial-contents - (not (lvar-matches-calls (combination-lvar call) - '(make-array-header* fill-array)))) - (compiler-style-warn 'initial-element-mismatch-style-warning - :format-control "The default initial element ~S is not a ~S." - :format-arguments (list default-initial-element elt-spec))))) - (let ((lambda-list `(length ,@(eliminate-keywords)))) - `(lambda ,lambda-list - (declare (ignorable ,@lambda-list)) - ,(with-alloc-form)))))))) + ,(wrap `(replace ,data-alloc-form initial-contents))))))))) ;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least ;;; specific must come first, otherwise suboptimal transforms will result for ;;; some forms. +;;; 3rd choice (deftransform make-array ((dims &key initial-element initial-contents element-type adjustable fill-pointer displaced-to displaced-index-offset) - (t &rest *) * + (t &rest t) * :node node) (delay-ir1-transform node :constraint) (when (and initial-contents initial-element) @@ -981,10 +1049,14 @@ ,@(maybe-arg fill-pointer) ,@(maybe-arg displaced-to) ,@(maybe-arg displaced-index-offset)))) - (cond ((or (not initial-element) - (and (constant-lvar-p initial-element) - (eql (lvar-value initial-element) - (sb-vm:saetp-initial-element-default saetp)))) + (cond ((not initial-element) creation-form) + ;; with ubsan the call to %MAKE-ARRAY needs to see the :INITIAL-ELEMENT + ;; even if it looks like the default, otherwise %MAKE-ARRAY reserves the right + ;; to scribble on the array. Same for allocators that don't prezero + #-ubsan + ((and (constant-lvar-p initial-element) + (eql (lvar-value initial-element) + (sb-vm:saetp-initial-element-default saetp))) creation-form) (t ;; error checking for target, disabled on the host because @@ -1020,6 +1092,7 @@ ;;; The list type restriction does not ensure that the result will be a ;;; multi-dimensional array. But the lack of adjustable, fill-pointer, ;;; and displaced-to keywords ensures that it will be simple. +;;; 2nd choice (deftransform make-array ((dims &key element-type initial-element initial-contents adjustable fill-pointer) @@ -1032,34 +1105,35 @@ * :node call) (block make-array - ;; If lvar-use of DIMS is a call to LIST, then it must mean that LIST - ;; was declared notinline - because if it weren't, then it would have been - ;; source-transformed into CONS - which gives us reason NOT to optimize - ;; this call to MAKE-ARRAY. So look for CONS instead of LIST, - ;; which means that LIST was *not* declared notinline. - (when (and (lvar-matches dims :fun-names '(cons) :arg-count 2) - (let ((cdr (second (combination-args (lvar-uses dims))))) - (and (constant-lvar-p cdr) (null (lvar-value cdr))))) - (let* ((args (splice-fun-args dims :any 2)) ; the args to CONS - (dummy (cadr args))) - (flush-dest dummy) + ;; Recognize vector construction where the length is spelled as (LIST n) + ;; or (LIST* n nil). Don't care if FUN-LEXICALLY-NOTINLINE-P on those because + ;; you can't portably observe whether they're called (tracing them isn't allowed). + ;; XXX: minor OAOO problem, see similar logic in (VALUES-LIST OPTIMIZER). + (awhen (cond ((and (lvar-matches dims :fun-names '(list) :arg-count 1)) + (car (splice-fun-args dims :any 1))) + ((and (lvar-matches dims :fun-names '(list*) :arg-count 2) + (lvar-value-is-nil (second (combination-args (lvar-uses dims))))) + (let* ((args (splice-fun-args dims :any 2)) ; the args to LIST* + (dummy (cadr args))) + (flush-dest dummy) + (setf (combination-args call) (delete dummy (combination-args call))) + (car args)))) ;; Don't want (list (list x)) to become a valid dimension specifier. - (assert-lvar-type (car args) (specifier-type 'index) - (%coerce-to-policy call)) - (setf (combination-args call) (delete dummy (combination-args call))) + (assert-lvar-type it (specifier-type 'index) (%coerce-to-policy call)) (return-from make-array - (transform-make-array-vector (car args) + (transform-make-array-vector it element-type initial-element initial-contents call :adjustable adjustable - :fill-pointer fill-pointer)))) + :fill-pointer fill-pointer))) (unless (constant-lvar-p dims) (give-up-ir1-transform "The dimension list is not constant; cannot open code array creation.")) (let ((dims (lvar-value dims)) - (element-type-ctype (and (constant-lvar-p element-type) + (element-type-ctype (and element-type + (constant-lvar-p element-type) (ir1-transform-specifier-type (lvar-value element-type))))) (when (or (contains-unknown-type-p element-type-ctype) @@ -1072,10 +1146,7 @@ initial-element initial-contents call :adjustable adjustable :fill-pointer fill-pointer)) - ((and fill-pointer - (not (and - (constant-lvar-p fill-pointer) - (null (lvar-value fill-pointer))))) + ((and fill-pointer (not (lvar-value-is-nil fill-pointer))) (give-up-ir1-transform)) (t (let* ((total-size (reduce #'* dims)) @@ -1120,6 +1191,7 @@ ;; dimensions ,@dims)))))))) +;;; 1st choice (deftransform make-array ((dims &key element-type initial-element initial-contents adjustable fill-pointer) (integer &key @@ -1444,10 +1516,12 @@ ;; chances to run. (delay-ir1-transform node :ir1-phases)) (if (vop-existsp :named test-header-bit) - `(test-header-bit array sb-vm:+array-fill-pointer-p+) - `(logtest (get-header-data array) sb-vm:+array-fill-pointer-p+)))))) + `(test-header-bit array + (ash sb-vm:+array-fill-pointer-p+ sb-vm:array-flags-data-position)) + `(logtest (get-header-data array) + (ash sb-vm:+array-fill-pointer-p+ sb-vm:array-flags-data-position))))))) -(deftransform %check-bound ((array dimension index) ((simple-array * (*)) * *)) +(deftransform %check-bound ((array dimension index) ((simple-array * (*)) t t)) (let ((array-ref (lvar-uses array)) (index-ref (lvar-uses index))) (unless (and @@ -1663,46 +1737,13 @@ (define-source-transform ,setter (a i v) `(setf (aref (the ,',type ,a) ,i) ,v))))) (define-frob schar %scharset simple-string) - (define-frob char %charset string)) + (define-frob char %charset string) + (define-frob svref %svset simple-vector)) -;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is -;;; around 100 times faster than going through the general-purpose AREF -;;; transform which ends up doing a lot of work -- and introducing many -;;; intermediate lambdas, each meaning a new trip through the compiler -- to -;;; get the same result. -;;; -;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar -;;; treatment. -(define-source-transform svref (vector index) - (let ((elt-type (or (when (symbolp vector) - (let ((var (lexenv-find vector vars))) - (when (lambda-var-p var) - (type-specifier - (array-type-declared-element-type (lambda-var-type var)))))) - t))) - (with-unique-names (n-vector) - `(let ((,n-vector ,vector)) - (the ,elt-type (data-vector-ref - (the simple-vector ,n-vector) - (check-bound ,n-vector (length ,n-vector) ,index))))))) - -(define-source-transform %svset (vector index value) - (let ((elt-type (or (when (symbolp vector) - (let ((var (lexenv-find vector vars))) - (when (lambda-var-p var) - (type-specifier - (array-type-declared-element-type (lambda-var-type var)))))) - t))) - (with-unique-names (n-vector) - `(let ((,n-vector ,vector)) - (truly-the ,elt-type (data-vector-set - (the simple-vector - (with-annotations - (,(make-lvar-modified-annotation :caller - '(setf svref))) - ,n-vector)) - (check-bound ,n-vector (length ,n-vector) ,index) - (the ,elt-type ,value))))))) +(defun the-unwild (type expr) + (if (or (null type) (eq type *wild-type*)) expr `(the ,type ,expr))) +(defun truly-the-unwild (type expr) + (if (or (null type) (eq type *wild-type*)) expr `(truly-the ,type ,expr))) (macrolet (;; This is a handy macro for computing the row-major index ;; given a set of indices. We wrap each index with a call @@ -1778,13 +1819,13 @@ (null (array-type-complexp type)) (neq element-ctype *wild-type*) (eql (length (array-type-dimensions type)) 1)) - (let* ((declared-element-ctype (array-type-declared-element-type type)) + (let* ((declared-element-ctype (array-type-element-type type)) (bare-form `(data-vector-ref array (check-bound array (array-dimension array 0) index)))) (if (type= declared-element-ctype element-ctype) bare-form - `(the ,(type-specifier declared-element-ctype) ,bare-form)))) + `(the ,declared-element-ctype ,bare-form)))) ((policy node (zerop insert-array-bounds-checks)) `(hairy-data-vector-ref array index)) (t `(hairy-data-vector-ref/check-bounds array index))))) @@ -1797,13 +1838,11 @@ ;;; But if we find out later that there's some useful type information ;;; available, switch back to the normal one to give other transforms ;;; a stab at it. -(macrolet ((define (name transform-to extra extra-type) - (declare (ignore extra-type)) - `(deftransform ,name ((array index ,@extra)) +(macrolet ((define (name args expr) + `(deftransform ,name ,args (let* ((type (lvar-type array)) (element-type (array-type-upgraded-element-type type)) - (declared-type (type-specifier - (array-type-declared-element-type type)))) + (declared-type (declared-array-element-type type))) ;; If an element type has been declared, we want to ;; use that information it for type checking (even ;; if the access can't be optimized due to the array @@ -1819,22 +1858,17 @@ (not (null (array-type-complexp type)))) (give-up-ir1-transform "Upgraded element type of array is not known at compile time."))) - ,(if extra - ``(truly-the ,declared-type - (,',transform-to array - (check-bound array - (array-dimension array 0) - index) - (the ,declared-type ,@',extra))) - ``(the ,declared-type - (,',transform-to array - (check-bound array - (array-dimension array 0) - index)))))))) - (define hairy-data-vector-ref/check-bounds - hairy-data-vector-ref nil nil) - (define hairy-data-vector-set/check-bounds - hairy-data-vector-set (new-value) (*))) + ,expr)))) + (define hairy-data-vector-ref/check-bounds ((array index)) + (the-unwild declared-type + `(hairy-data-vector-ref + array (check-bound array (array-dimension array 0) index)))) + (define hairy-data-vector-set/check-bounds ((array index new-value)) + (truly-the-unwild declared-type + `(hairy-data-vector-set + array + (check-bound array (array-dimension array 0) index) + ,(the-unwild declared-type 'new-value))))) ;;; Just convert into a HAIRY-DATA-VECTOR-REF (or ;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the diff -Nru sbcl-2.1.1/src/compiler/assem.lisp sbcl-2.1.11/src/compiler/assem.lisp --- sbcl-2.1.1/src/compiler/assem.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/assem.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -319,18 +319,38 @@ (defstruct asmstream (data-section (make-section) :read-only t) + (indirections-section (make-section) :read-only t) (code-section (make-section) :read-only t) (elsewhere-section (make-section) :read-only t) + (data-origin-label (gen-label "data start") :read-only t) + (text-origin-label (gen-label "text start") :read-only t) (elsewhere-label (gen-label "elsewhere start") :read-only t) (inter-function-padding :normal :type (member :normal :nop)) ;; for collecting unique "unboxed constants" prior to placing them ;; into the data section (constant-table (make-hash-table :test #'equal) :read-only t) (constant-vector (make-array 16 :adjustable t :fill-pointer 0) :read-only t) + ;; for deterministic allocation profiler (or possibly other tooling) + ;; that wants to monkey patch the instructions at runtime. + (alloc-points) + ;; for shrinking the size of the code fixups, we can choose to emit at most one call + ;; from a dynamic space code component to a given assembly routine. The call goes + ;; through an extra indirection in the component. + ;; This table is stored as an alist of (NAME . LABEL). + (indirection-table) ;; tracking where we last wrote an instruction so that SB-C::TRACE-INSTRUCTION ;; can print "in the {x} section" whenever it changes. (tracing-state (list nil nil) :read-only t)) ; segment and vop (declaim (freeze-type asmstream)) +;;; FIXME: suboptimal since *asmstream* was declaimed earlier because reasons. +;;; (so we're missing uses of the known type even though the special var is known) +(declaim (type asmstream *asmstream*)) + +(defun get-allocation-points (asmstream) + ;; Convert the label positions to a packed integer + ;; Utilize PACK-CODE-FIXUP-LOCS to perform compression. + (awhen (mapcar 'label-posn (asmstream-alloc-points asmstream)) + (sb-c:pack-code-fixup-locs it nil nil))) ;;; Insert STMT after PREDECESSOR. (defun insert-stmt (stmt predecessor) @@ -363,7 +383,7 @@ (if (singleton-p list) (car list) list)))) ;;; This is used only to keep track of which vops emit which insts. -(defvar **current-vop**) +(defvar *current-vop*) ;;; Return the final statement emitted. (defun emit (section &rest things) @@ -372,7 +392,7 @@ ;; - a list (mnemonic . operands) for a machine instruction or assembler directive ;; - a function to emit a postit (let ((last (section-tail section)) - (vop (if (boundp '**current-vop**) **current-vop**))) + (vop (if (boundp '*current-vop*) *current-vop*))) (dolist (thing things (setf (section-tail section) last)) (if (label-p thing) ; Accumulate multiple labels until the next instruction (if (stmt-mnemonic last) @@ -434,9 +454,10 @@ ,(case dest (:code '(asmstream-code-section *asmstream*)) (:elsewhere '(asmstream-elsewhere-section *asmstream*)) + (:indirections + '(asmstream-indirections-section *asmstream*)) (t dest))))) - ,@(when vop - `((**current-vop** ,vop))) + ,@(when vop `((*current-vop* ,vop))) ,@(mapcar (lambda (name) `(,name (gen-label))) new-labels)) @@ -1417,7 +1438,7 @@ ;;; Combine INPUTS into one assembly stream and assemble into SEGMENT (defun %assemble (segment section) - (let ((**current-vop** nil) + (let ((*current-vop* nil) (in-without-scheduling) (was-scheduling)) ;; HEADER-SKEW is 1 word (in bytes) if the boxed code header word count is odd. @@ -1442,9 +1463,9 @@ (dump-symbolic-asm section sb-c::*compiler-trace-output*)) (do ((statement (stmt-next (section-start section)) (stmt-next statement))) ((null statement)) - (awhen (stmt-vop statement) (setq **current-vop** it)) + (awhen (stmt-vop statement) (setq *current-vop* it)) (dolist (label (ensure-list (stmt-labels statement))) - (%emit-label segment **current-vop** label)) + (%emit-label segment *current-vop* label)) (let ((mnemonic (stmt-mnemonic statement)) (operands (stmt-operands statement))) (if (functionp mnemonic) @@ -1481,8 +1502,10 @@ (end-text (gen-label)) (combined (append-sections - (append-sections (asmstream-data-section asmstream) - (asmstream-code-section asmstream)) + (append-sections (asmstream-data-section asmstream) + (append-sections + (asmstream-code-section asmstream) + (asmstream-indirections-section asmstream))) (let ((section (asmstream-elsewhere-section asmstream))) (emit section end-text @@ -1564,7 +1587,7 @@ (if (eq section (asmstream-code-section asmstream)) :regular :elsewhere))) - (sb-c::trace-instruction section-name **current-vop** mnemonic operands + (sb-c::trace-instruction section-name *current-vop* mnemonic operands (asmstream-tracing-state asmstream))))) (defmacro inst (&whole whole mnemonic &rest args) @@ -1600,9 +1623,20 @@ ;;; As such, we must detect that we are emitting directly to machine code. ;;; (defun inst* (mnemonic &rest operands) - (declare (symbol mnemonic)) - (let ((action (gethash mnemonic *inst-encoder*)) - (dest *current-destination*)) + (let ((dest + (etypecase mnemonic + (symbol + ;; If called by a vop, the first argument is a mnemonic. + *current-destination*) + (segment + ;; If called by an instruction encoder to encode other instructions, + ;; the first argument is a SEGMENT. This facilitates a different kind of + ;; macro-instruction, one which decides only at encoding time what other + ;; instructions to emit. Similar results could be achievedy by factoring + ;; out other emitters into callable functions, though the INST macro + ;; tends to be a more convenient interface. + (prog1 mnemonic (setq mnemonic (the symbol (pop operands))))))) + (action (gethash mnemonic *inst-encoder*))) (unless action ; try canonicalizing again (setq mnemonic (find-symbol (string mnemonic) *backend-instruction-set-package*) @@ -1634,13 +1668,6 @@ (trace-inst s :align bits) (emit s `(.align ,bits ,pattern)))) -;; ECL bug workaround: it miscompiles LABEL-POSITION with this decl -;; This might be unnecessary now that I'm proclaiming an OPTIMIZE policy -;; that seems to fix everything. It certainly was needed without that. -;; At least by keeping this we might be able to report some specific bugs -;; against ECL in the hope it gets fixed. Of course we can't actually ever -;; remove workarounds. -#-host-quirks-ecl (declaim (ftype (sfunction (label &optional t index) (or null index)) label-position)) (defun label-position (label &optional if-after delta) @@ -1895,7 +1922,7 @@ ',fun-name (named-lambda ,(string fun-name) (,segment-name ,@operands) (declare ,@decls) - (let ,(and vop-name `((,vop-name **current-vop**))) + (let ,(and vop-name `((,vop-name *current-vop*))) (block ,fun-name ,@emitter))) ',accept-prefixes)))) ',fun-name))) @@ -1921,7 +1948,7 @@ (%def-inst-encoder '.align (lambda (segment bits &optional (pattern 0)) - (%emit-alignment segment **current-vop** bits pattern))) + (%emit-alignment segment *current-vop* bits pattern))) (%def-inst-encoder '.byte (lambda (segment &rest bytes) (dolist (byte bytes) (emit-byte segment byte)))) diff -Nru sbcl-2.1.1/src/compiler/backend.lisp sbcl-2.1.11/src/compiler/backend.lisp --- sbcl-2.1.1/src/compiler/backend.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/backend.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -67,10 +67,7 @@ ;;; representation. ;;; ;;; The T primitive-type is kept in this variable so that people who -;;; have to special-case it can get at it conveniently. This variable -;;; has to be set by the machine-specific VM definition, since the -;;; !DEF-PRIMITIVE-TYPE for T must specify the SCs that boxed objects -;;; can be allocated in. +;;; have to special-case it can get at it conveniently. (define-symbol-macro *backend-t-primitive-type* (the primitive-type (load-time-value (primitive-type-or-lose t) t))) @@ -163,12 +160,9 @@ |# ;;; The default value of NIL means use only unguarded VOPs. The -;;; initial value is customizeable via -;;; customize-backend-subfeatures.lisp -(eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *backend-subfeatures* - '#.(sort (copy-list sb-cold:*shebang-backend-subfeatures*) #'string<))) -(declaim (always-bound *backend-subfeatures*)) +;;; initial value is customizeable via customize-backend-subfeatures.lisp +(defvar *backend-subfeatures* '#.(sort sb-cold:backend-subfeatures #'string<)) +#-sb-xc-host (declaim (always-bound *backend-subfeatures*)) ;;; possible *BACKEND-SUBFEATURES* values: ;;; diff -Nru sbcl-2.1.1/src/compiler/bitops-derive-type.lisp sbcl-2.1.11/src/compiler/bitops-derive-type.lisp --- sbcl-2.1.1/src/compiler/bitops-derive-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/bitops-derive-type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -139,6 +139,12 @@ (defun logand-derive-type-aux (x y &optional same-leaf) (when same-leaf (return-from logand-derive-type-aux x)) + (flet ((minus-one (x y) + (when (eql (nth-value 1 (type-singleton-p x)) + -1) + (return-from logand-derive-type-aux y)))) + (minus-one x y) + (minus-one y x)) (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x) (declare (ignore x-pos)) (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y) @@ -175,20 +181,6 @@ ;; We can't tell squat about the result. (specifier-type 'integer))))))) -(defun make-modular-fun-type-deriver (prototype kind width signedp) - (declare (ignore kind)) - (let ((info (fun-info-or-lose prototype)) - (mask-type (specifier-type - (ecase signedp - ((nil) (let ((mask (1- (ash 1 width)))) - `(integer ,mask ,mask))) - ((t) `(signed-byte ,width)))))) - (lambda (call) - (let ((res (funcall (fun-info-derive-type info) call))) - (when (and res - (not signedp)) - (logand-derive-type-aux res mask-type)))))) - (defun logior-derive-unsigned-bounds (x y) (let* ((a (numeric-type-low x)) (b (numeric-type-high x)) diff -Nru sbcl-2.1.1/src/compiler/callable-args.lisp sbcl-2.1.11/src/compiler/callable-args.lisp --- sbcl-2.1.1/src/compiler/callable-args.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/callable-args.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -200,7 +200,8 @@ (t lvar-type))) (fun-name (cond ((or (fun-type-p lvar-type) - (functional-p leaf)) + (functional-p leaf) + (global-var-p leaf)) (cond ((or (constant-lvar-p lvar) ;; A constant may fail some checks in constant-lvar-p (constant-p leaf)) @@ -413,6 +414,18 @@ "The function ~s is called with odd number of keyword arguments." callee))))))) +(defun disable-arg-count-checking (leaf type arg-count) + (when (lambda-p leaf) + (multiple-value-bind (min max) (fun-type-arg-limits type) + (when (and min + (if max + (<= min arg-count max) + (<= min arg-count))) + (setf (lambda-lexenv leaf) + (make-lexenv :default (lambda-lexenv leaf) + :policy (augment-policy verify-arg-count 0 + (lexenv-policy (lambda-lexenv leaf))))))))) + ;;; This can provide better errors and better handle OR types than a ;;; simple type intersection. (defun check-function-designator-lvar (lvar annotation) @@ -444,6 +457,9 @@ arg-count condition) (let ((param-types (fun-type-n-arg-types arg-count type))) + (unless (and (eq caller 'reduce) + (eql arg-count 2)) + (disable-arg-count-checking leaf type arg-count)) (block nil ;; Need to check each OR seperately, a UNION could ;; intersect with the function parameters diff -Nru sbcl-2.1.1/src/compiler/checkgen.lisp sbcl-2.1.11/src/compiler/checkgen.lisp --- sbcl-2.1.1/src/compiler/checkgen.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/checkgen.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -454,27 +454,28 @@ ;;; for the common MV-BIND case. (defun make-type-check-form (types cast) (let ((temps (make-gensym-list (length types)))) - `(multiple-value-bind ,temps 'dummy - ,@(mapcar - (lambda (temp %type) - (destructuring-bind (not type-to-check - type-to-report) %type - (let* ((spec - (let ((*unparse-fun-type-simplify* t)) - (type-specifier type-to-check))) - (test (if not `(not ,spec) spec))) - `(unless - ,(with-ir1-environment-from-node cast ;; it performs its own inlining of SATISFIES - (%source-transform-typep temp test)) - ,(internal-type-error-call temp - (if (fun-designator-type-p type-to-report) - ;; Simplify - (specifier-type 'function-designator) - type-to-report) - (cast-context cast)))))) - temps - types) - (values ,@temps)))) + (lambda (dummy) + `(multiple-value-bind ,temps ,dummy + ,@(mapcar + (lambda (temp %type) + (destructuring-bind (not type-to-check + type-to-report) %type + (let* ((spec + (let ((*unparse-fun-type-simplify* t)) + (type-specifier type-to-check))) + (test (if not `(not ,spec) spec))) + `(unless + ,(with-ir1-environment-from-node cast ;; it performs its own inlining of SATISFIES + (%source-transform-typep temp test)) + ,(internal-type-error-call temp + (if (fun-designator-type-p type-to-report) + ;; Simplify + (specifier-type 'function-designator) + type-to-report) + (cast-context cast)))))) + temps + types) + (values ,@temps))))) ;;; Splice in explicit type check code immediately before CAST. This ;;; code receives the value(s) that were being passed to CAST-VALUE, @@ -499,9 +500,11 @@ (not-ok-uses '())) (do-uses (use value) (let ((dtype (node-derived-type use))) - (if (values-types-equal-or-intersect dtype atype) - (setf condition 'type-style-warning) - (push use not-ok-uses)))) + (cond ((values-types-equal-or-intersect dtype atype) + (setf condition 'type-style-warning)) + ((cast-mismatch-from-inlined-p cast use)) + (t + (push use not-ok-uses))))) (dolist (use (nreverse not-ok-uses)) (let* ((*compiler-error-context* use) (dtype (node-derived-type use)) diff -Nru sbcl-2.1.1/src/compiler/codegen.lisp sbcl-2.1.11/src/compiler/codegen.lisp --- sbcl-2.1.1/src/compiler/codegen.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/codegen.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,24 +18,22 @@ ;;; the number of bytes used by the code object header -#-sb-xc-host -(defun component-header-length (&optional - (component *component-being-compiled*)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp))) - (ash (align-up (length constants) code-boxed-words-align) sb-vm:word-shift))) - -;;; KLUDGE: the assembler can not emit backpatches comprising jump tables without -;;; knowing the boxed code header length. But there is no compiler IR2 metaobject, -;;; for SB-FASL:*ASSEMBLER-ROUTINES*. We have to return a fixed answer for that. -#+sb-xc-host -(defun component-header-length () - (if (boundp '*component-being-compiled*) - (let ((component *component-being-compiled*)) - (let* ((2comp (component-info component)) - (constants (ir2-component-constants 2comp))) - (ash (align-up (length constants) code-boxed-words-align) sb-vm:word-shift))) - (* sb-vm:n-word-bytes 4))) +(macrolet ((header-length-in-bytes (comp) + `(let* ((2comp (component-info ,comp)) + (constants (ir2-component-constants 2comp))) + (ash (align-up (length constants) code-boxed-words-align) + sb-vm:word-shift)))) + #-sb-xc-host + (defun component-header-length (&optional (component *component-being-compiled*)) + (header-length-in-bytes component)) + ;; KLUDGE: the assembler can not emit backpatches comprising jump tables without + ;; knowing the boxed code header length. But there is no compiler IR2 metaobject, + ;; for SB-FASL:*ASSEMBLER-ROUTINES*. We have to return a fixed answer for that. + #+sb-xc-host + (defun component-header-length () + (if (boundp '*component-being-compiled*) + (header-length-in-bytes *component-being-compiled*) + (* sb-vm:n-word-bytes (align-up sb-vm:code-constants-offset 2))))) ;;; the size of the NAME'd SB in the currently compiled component. ;;; This is useful mainly for finding the size for allocating stack @@ -48,9 +46,9 @@ (defun current-nfp-tn (vop) (unless (zerop (sb-allocated-size 'non-descriptor-stack)) (let ((block (ir2-block-block (vop-block vop)))) - (when (ir2-physenv-number-stack-p - (physenv-info - (block-physenv block))) + (when (ir2-environment-number-stack-p + (environment-info + (block-environment block))) (ir2-component-nfp (component-info (block-component block))))))) ;;; the TN that is used to hold the number stack frame-pointer in the @@ -58,13 +56,13 @@ ;;; allocated (defun callee-nfp-tn (2env) (unless (zerop (sb-allocated-size 'non-descriptor-stack)) - (when (ir2-physenv-number-stack-p 2env) + (when (ir2-environment-number-stack-p 2env) (ir2-component-nfp (component-info *component-being-compiled*))))) ;;; the TN used for passing the return PC in a local call to the function ;;; designated by 2ENV (defun callee-return-pc-tn (2env) - (ir2-physenv-return-pc-pass 2env)) + (ir2-environment-return-pc-pass 2env)) ;;;; noise to emit an instruction trace @@ -125,7 +123,7 @@ ;;; to get handles (as returned by sb-vm:inline-constant-value) from constant ;;; descriptors. ;;; -#+(or arm arm64 mips ppc ppc64 x86 x86-64) +#+(or arm64 mips ppc ppc64 x86 x86-64) (defun register-inline-constant (&rest constant-descriptor) ;; N.B.: Please do not think yourself so clever as to declare DYNAMIC-EXTENT on ;; CONSTANT-DESCRIPTOR. Giving the list indefinite extent allows backends to simply @@ -141,7 +139,7 @@ (vector-push-extend (cons constant label) (asmstream-constant-vector asmstream)) value))))) -#-(or arm arm64 mips ppc ppc64 x86 x86-64) +#-(or arm64 mips ppc ppc64 x86 x86-64) (progn (defun sb-vm:sort-inline-constants (constants) constants) (defun sb-vm:emit-inline-constant (&rest args) (error "EMIT-INLINE-CONSTANT called with ~S" args))) @@ -268,21 +266,43 @@ (defglobal *static-vop-usage-counts* nil) (defparameter *do-instcombine-pass* t) -(defun generate-code (component) +(defun generate-code (component &aux (ir2-component (component-info component))) + (declare (type ir2-component ir2-component)) (when *compiler-trace-output* - (format *compiler-trace-output* - "~|~%assembly code for ~S~2%" - component)) + (let ((*print-pretty* nil)) ; force 1 line + (format *compiler-trace-output* "~|~%assembly code for ~S~2%" component))) (let* ((prev-env nil) ;; The first function's alignment word is zero-filled, but subsequent ;; ones can use a NOP which helps the disassembler not lose sync. (filler-pattern 0) (asmstream (make-asmstream)) + (coverage-map) (*asmstream* asmstream)) + (declare (ignorable coverage-map)) (emit (asmstream-elsewhere-section asmstream) (asmstream-elsewhere-label asmstream)) + #-(or x86 x86-64) + (let ((path->index (make-hash-table :test 'equal))) + ;; Pre-scan for MARK-COVERED vops and collect the set of + ;; distinct source paths that occur. Delay adding the coverage map to + ;; the boxed constant vector until all vop generators have run, because + ;; they can use EMIT-CONSTANT to add more constants, + ;; while the coverage map has to be the very last entry in the vector. + (do-ir2-blocks (block component) + (do ((vop (ir2-block-start-vop block) (vop-next vop))) + ((null vop)) + (when (eq (vop-name vop) 'mark-covered) + (setf (vop-codegen-info vop) + (list (ensure-gethash (car (vop-codegen-info vop)) + path->index + (hash-table-count path->index))))))) + (when (plusp (hash-table-count path->index)) + (setf coverage-map (make-array (hash-table-count path->index))) + (maphash (lambda (path index) (setf (aref coverage-map index) path)) + path->index))) + (do-ir2-blocks (block component) (let ((1block (ir2-block-block block))) (when (and (eq (block-info 1block) block) @@ -307,10 +327,10 @@ (ir2-block-%trampoline-label block) (ir2-block-dropped-thru-to block) alignp))) - (let ((env (block-physenv 1block))) + (let ((env (block-environment 1block))) (unless (eq env prev-env) - (let ((lab (gen-label "physenv elsewhere start"))) - (setf (ir2-physenv-elsewhere-start (physenv-info env)) + (let ((lab (gen-label "environment elsewhere start"))) + (setf (ir2-environment-elsewhere-start (environment-info env)) lab) (emit (asmstream-elsewhere-section asmstream) lab)) (setq prev-env env))))) @@ -336,33 +356,51 @@ (funcall gen vop))))))) (when *do-instcombine-pass* - #+x86-64 + #+(or arm64 x86-64) (sb-assem::combine-instructions (asmstream-code-section asmstream))) + (emit (asmstream-data-section asmstream) + (sb-assem::asmstream-data-origin-label asmstream)) ;; Jump tables precede the coverage mark bytes to simplify locating ;; them in trans_code(). (emit-jump-tables) ;; Todo: can we implement the flow-based aspect of coverage mark compression ;; in IR2 instead of waiting until assembly generation? - (coverage-mark-lowering-pass component asmstream) + #+(or x86 x86-64) (coverage-mark-lowering-pass component asmstream) + ;; The #+(or x86 x86-64) case has _already_ output the mark bytes into + ;; the data section in lowering pass, so we don't do that here. + #-(or x86 x86-64) + (when coverage-map + #+arm64 + (vector-push-extend (make-constant (make-array (length coverage-map) + :element-type '(unsigned-byte 8) + :initial-element #xFF)) + (ir2-component-constants ir2-component)) + (vector-push-extend (make-constant (cons 'coverage-map coverage-map)) + (ir2-component-constants ir2-component)) + ;; The mark vop can store the low byte from either ZERO-TN or NULLL-TN + ;; to avoid loading a constant. Either one won't match #xff. + #-arm64 + (emit (asmstream-data-section asmstream) + `(.skip ,(length coverage-map) #xff))) + (emit-inline-constants) - (let* ((info (component-info component)) - (simple-fun-labels - (mapcar #'entry-info-offset (ir2-component-entries info))) - (n-boxed (length (ir2-component-constants info))) + (let* ((n-boxed (length (ir2-component-constants ir2-component))) ;; Skew is either 0 or N-WORD-BYTES depending on whether the boxed ;; header length is even or odd (skew (if (and (= code-boxed-words-align 1) (oddp n-boxed)) sb-vm:n-word-bytes 0))) (multiple-value-bind (segment text-length fixup-notes fun-table) - (assemble-sections asmstream - simple-fun-labels - (make-segment :header-skew skew - :run-scheduler (default-segment-run-scheduler))) + (assemble-sections + asmstream + (mapcar #'entry-info-offset (ir2-component-entries ir2-component)) + (make-segment :header-skew skew + :run-scheduler (default-segment-run-scheduler))) (values segment text-length fun-table - (asmstream-elsewhere-label asmstream) fixup-notes))))) + (asmstream-elsewhere-label asmstream) fixup-notes + (sb-assem::get-allocation-points asmstream)))))) (defun label-elsewhere-p (label-or-posn kind) (let ((elsewhere (label-position *elsewhere-label*)) diff -Nru sbcl-2.1.1/src/compiler/compiler-deftype.lisp sbcl-2.1.11/src/compiler/compiler-deftype.lisp --- sbcl-2.1.1/src/compiler/compiler-deftype.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/compiler-deftype.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -;;;; that part of DEFTYPE which runs within the compiler itself - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-IMPL") - -(/show0 "compiler-deftype.lisp 14") - -(defun %compiler-deftype (name expander source-location &optional doc) - (declare (ignorable doc)) - (with-single-package-locked-error - (:symbol name "defining ~A as a type specifier")) - (ecase (info :type :kind name) - (:primitive - ;; Detecting illegal redefinition in the cross-compiler - ;; adds unnecessary complexity, so don't bother. - #-sb-xc-host - (when *type-system-initialized* - (error "illegal to redefine standard type: ~S" name))) - (:instance - (warn "The class ~S is being redefined to be a DEFTYPE." name) - (undeclare-structure (find-classoid name) t) - ;; FIXME: shouldn't this happen only at eval-time? - (setf (classoid-cell-classoid (find-classoid-cell name :create t)) nil) - (clear-info :type :compiler-layout name) - (setf (info :type :kind name) :defined)) - (:defined - ;; Note: It would be nice to warn here when a type is being - ;; incompatibly redefined, but it's hard to tell, since type - ;; expanders are often function objects which can't easily be - ;; compared for equivalence. And just warning on redefinition - ;; isn't good, since DEFTYPE necessarily does its thing once at - ;; compile time and again at load time, so that it's very common - ;; and normal for types to be defined twice. So since there - ;; doesn't seem to be anything simple and obvious to do, and - ;; since mistakenly redefining a type isn't a common error - ;; anyway, we just don't worry about trying to warn about it. - ) - ((nil :forthcoming-defclass-type) - (setf (info :type :kind name) :defined))) - (setf (info :type :expander name) expander) - (when source-location - (setf (info :type :source-location name) source-location)) - #-sb-xc-host - (when doc - (setf (documentation name 'type) doc)) - (sb-c::%note-type-defined name) - name) - -(/show0 "compiler-deftype.lisp end of file") diff -Nru sbcl-2.1.1/src/compiler/constantp.lisp sbcl-2.1.11/src/compiler/constantp.lisp --- sbcl-2.1.1/src/compiler/constantp.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/constantp.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,7 +11,7 @@ (in-package "SB-C") -(defparameter *special-constant-variables* nil) +(defvar *special-constant-variables* nil) (defun %constantp (form environment envp) ;; Pick off quasiquote prior to macroexpansion. diff -Nru sbcl-2.1.1/src/compiler/control.lisp sbcl-2.1.11/src/compiler/control.lisp --- sbcl-2.1.1/src/compiler/control.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/control.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -66,15 +66,15 @@ (defun find-rotated-loop-head (block) (declare (type cblock block)) (let* ((num (block-number block)) - (env (block-physenv block)) + (env (block-environment block)) (pred (dolist (pred (block-pred block) nil) (when (and (not (block-flag pred)) - (eq (block-physenv pred) env) + (eq (block-environment pred) env) (< (block-number pred) num)) (return pred))))) (cond ((and pred - (not (physenv-nlx-info env)) + (not (environment-nlx-info env)) (not (eq (lambda-block (block-home-lambda block)) block)) (null (cdr (block-succ pred)))) (let ((current pred) @@ -85,7 +85,7 @@ (when (eq pred block) (return-from DONE)) (when (and (not (block-flag pred)) - (eq (block-physenv pred) env) + (eq (block-environment pred) env) (> (block-number pred) current-num)) (setq current pred current-num (block-number pred)) (return))))) @@ -127,8 +127,8 @@ (let ((last (block-last block))) (cond ((and (combination-p last) (node-tail-p last) (eq (basic-combination-kind last) :local) - (not (eq (node-physenv last) - (lambda-physenv (combination-lambda last))))) + (not (eq (node-environment last) + (lambda-environment (combination-lambda last))))) (combination-lambda last)) (t (let ((component-tail (component-tail (block-component block))) @@ -160,7 +160,7 @@ (prev-block (block-annotation-prev tail-block)) (bind-block (node-block (lambda-bind fun)))) (unless (block-flag bind-block) - (dolist (nlx (physenv-nlx-info (lambda-physenv fun))) + (dolist (nlx (environment-nlx-info (lambda-environment fun))) (control-analyze-block (nlx-info-target nlx) tail-block)) (cond ((block-flag bind-block) diff -Nru sbcl-2.1.1/src/compiler/copyprop.lisp sbcl-2.1.11/src/compiler/copyprop.lisp --- sbcl-2.1.1/src/compiler/copyprop.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/copyprop.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -79,6 +79,8 @@ (and (or (not (tn-sc arg-tn)) (eq (tn-kind arg-tn) :constant)) (or + (subsetp (primitive-type-scs (tn-primitive-type tn)) + (primitive-type-scs (tn-primitive-type arg-tn))) (let ((reads (tn-reads tn))) ;; For moves to another moves the SC does ;; not matter, the intermediate SC will @@ -90,11 +92,7 @@ ;; Except for fixnums which may benifit from improved representation selection ;; if there is a way to go through an any-reg "adapter" (not (memq sb-vm:any-reg-sc-number (primitive-type-scs (tn-primitive-type tn)))) - (not (memq sb-vm:any-reg-sc-number (primitive-type-scs (tn-primitive-type arg-tn)))))) - (subsetp (primitive-type-scs - (tn-primitive-type tn)) - (primitive-type-scs - (tn-primitive-type arg-tn)))) + (not (memq sb-vm:any-reg-sc-number (primitive-type-scs (tn-primitive-type arg-tn))))))) (let ((leaf (tn-leaf tn))) (or (not leaf) (and diff -Nru sbcl-2.1.1/src/compiler/ctype.lisp sbcl-2.1.11/src/compiler/ctype.lisp --- sbcl-2.1.1/src/compiler/ctype.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ctype.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -117,15 +117,16 @@ (caller (loop for annotation in (lvar-annotations fun) when (typep annotation 'lvar-function-designator-annotation) do (setf *compiler-error-context* annotation) - (return (lvar-function-designator-annotation-caller annotation))))) + (return (lvar-function-designator-annotation-caller annotation)))) + (name (nth-value 1 (lvar-fun-type fun)))) (cond - ((report-arg-count-mismatch (nth-value 1 (lvar-fun-type fun)) + ((report-arg-count-mismatch name caller type nargs nil :lossage-fun #'note-lossage)) (t (check-fixed-and-rest args (append required optional) rest) (when (and keyp - (check-key-args args max-args type)) + (check-key-args name args max-args type)) (setf unknown-keys t)))) (when result-test @@ -286,8 +287,9 @@ ;;; be known and the corresponding argument should be of the correct ;;; type. If the key isn't a constant, then we can't tell, so we can ;;; complain about absence of manifest winnage. -(declaim (ftype (function (list fixnum fun-type) boolean) check-key-args)) -(defun check-key-args (args pre-key type) +(declaim (ftype (function (t list fixnum fun-type) boolean) check-key-args)) +(defun check-key-args (name args pre-key type) + (declare (ignorable name)) (let (lossages allow-other-keys unknown-keys) (do ((key (nthcdr pre-key args) (cddr key)) @@ -325,12 +327,18 @@ (1+ n))))))))) (when (and lossages (member allow-other-keys '(nil :no))) (setf lossages (nreverse lossages)) - (if (cdr lossages) - (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>" - (butlast lossages) - (car (last lossages))) - (note-lossage "~S is not a known argument keyword." - (car lossages)))) + + (cond #-sb-xc-host + ((or (eq (info :function :type name) :generic-function) + (eq (info :function :where-from name) :defined-method)) + (note-key-arg-mismatch name lossages)) + ((cdr lossages) + (note-lossage "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>" + (butlast lossages) + (car (last lossages)))) + (t + (note-lossage "~S is not a known argument keyword." + (car lossages))))) unknown-keys)) ;;; Construct a function type from a definition. @@ -1165,30 +1173,3 @@ ~2I~_~/sb-impl:print-type-specifier/.~@:>" :format-arguments (list (rest detail) (first detail) dtype atype)))))) - - -(defoptimizer (%compile-time-type-error ir2-convert) - ((objects atype dtype detail code-context cast-context) node block) - (declare (ignore objects code-context)) - ;; Remove %COMPILE-TIME-TYPE-ERROR bits - (setf (node-source-path node) - (cdr (node-source-path node))) - (%compile-time-type-error-warn node - (lvar-value atype) - (lvar-value dtype) - (lvar-value detail) - :cast-context (lvar-value cast-context)) - (ir2-convert-full-call node block)) - -(defoptimizer (%compile-time-type-style-warn ir2-convert) - ((objects atype dtype detail code-context cast-context) node block) - (declare (ignore objects code-context block)) - ;; Remove %COMPILE-TIME-TYPE-ERROR bits - (setf (node-source-path node) - (cddr (node-source-path node))) - (%compile-time-type-error-warn node - (lvar-value atype) - (lvar-value dtype) - (lvar-value detail) - :cast-context (lvar-value cast-context) - :condition 'type-style-warning)) diff -Nru sbcl-2.1.1/src/compiler/debug-dump.lisp sbcl-2.1.11/src/compiler/debug-dump.lisp --- sbcl-2.1.1/src/compiler/debug-dump.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/debug-dump.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -77,10 +77,10 @@ (- posn (segment-header-skew segment)))))) (values)) -(declaim (inline ir2-block-physenv)) -(defun ir2-block-physenv (2block) +(declaim (inline ir2-block-environment)) +(defun ir2-block-environment (2block) (declare (type ir2-block 2block)) - (block-physenv (ir2-block-block 2block))) + (block-environment (ir2-block-block 2block))) (defun make-lexenv-var-cache (lexenv) (or (lexenv-var-cache lexenv) @@ -314,13 +314,13 @@ (let ((*previous-location* 0) *previous-live* *previous-form-number* - (physenv (lambda-physenv fun)) + (env (lambda-environment fun)) (byte-buffer *byte-buffer*) prev-block locations elsewhere-locations) (setf (fill-pointer byte-buffer) 0) - (do-physenv-ir2-blocks (2block physenv) + (do-environment-ir2-blocks (2block env) (let ((block (ir2-block-block 2block))) (when (eq (block-info block) 2block) (when prev-block @@ -347,19 +347,19 @@ (declare (type source-info info)) (let ((file-info (get-toplevelish-file-info info))) (multiple-value-call - (if function #'sb-c::make-core-debug-source #'make-debug-source) + (if function 'sb-di::make-core-debug-source 'make-debug-source) :namestring (or *source-namestring* (make-file-info-namestring (let ((pathname (case *name-context-file-path-selector* - (pathname (file-info-untruename file-info)) - (truename (file-info-name file-info))))) + (pathname (file-info-pathname file-info)) + (truename (file-info-truename file-info))))) (if (pathnamep pathname) pathname)) file-info)) :created (file-info-write-date file-info) (if function (values :form (let ((direct-file-info (source-info-file-info info))) - (when (eq :lisp (file-info-name direct-file-info)) + (when (eq :lisp (file-info-truename direct-file-info)) (elt (file-info-forms direct-file-info) 0))) :function function) (values))))) @@ -447,12 +447,12 @@ (info (lambda-var-arg-info var)) (indirect (and (lambda-var-indirect var) (not (lambda-var-explicit-value-cell var)) - (neq (lambda-physenv fun) - (lambda-physenv (lambda-var-home var))))) + (neq (lambda-environment fun) + (lambda-environment (lambda-var-home var))))) ;; Keep this condition in sync with PARSE-COMPILED-DEBUG-VARS (large-fixnums (>= (integer-length most-positive-fixnum) 62)) more) - (declare (type index flags)) + (declare (type (and sb-xc:fixnum unsigned-byte) flags)) (when minimal (setq flags (logior flags compiled-debug-var-minimal-p)) (unless (and tn (tn-offset tn)) @@ -552,7 +552,7 @@ (frob-leaf leaf (leaf-info leaf) gensym-p)))) (frob-lambda fun t) (when (>= level 1) - (dolist (x (ir2-physenv-closure (physenv-info (lambda-physenv fun)))) + (dolist (x (ir2-environment-closure (environment-info (lambda-environment fun)))) (let ((thing (car x))) (when (lambda-var-p thing) (frob-leaf thing (cdr x) (>= level 2))))) @@ -662,7 +662,7 @@ ;;; Return a C-D-F structure with all the mandatory slots filled in. (defun dfun-from-fun (fun) (declare (type clambda fun)) - (let* ((2env (physenv-info (lambda-physenv fun))) + (let* ((2env (environment-info (lambda-environment fun))) (dispatch (lambda-optional-dispatch fun)) (main-p (and dispatch (eq fun (optional-dispatch-main-entry dispatch)))) @@ -685,26 +685,26 @@ (funcall (compiled-debug-fun-ctor kind) :name name #-fp-and-pc-standard-save :return-pc - #-fp-and-pc-standard-save (tn-sc+offset (ir2-physenv-return-pc 2env)) + #-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-return-pc 2env)) #-fp-and-pc-standard-save :return-pc-pass - #-fp-and-pc-standard-save (tn-sc+offset (ir2-physenv-return-pc-pass 2env)) + #-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-return-pc-pass 2env)) #-fp-and-pc-standard-save :old-fp - #-fp-and-pc-standard-save (tn-sc+offset (ir2-physenv-old-fp 2env)) + #-fp-and-pc-standard-save (tn-sc+offset (ir2-environment-old-fp 2env)) :encoded-locs (cdf-encode-locs - (label-position (ir2-physenv-environment-start 2env)) - (label-position (ir2-physenv-elsewhere-start 2env)) + (label-position (ir2-environment-environment-start 2env)) + (label-position (ir2-environment-elsewhere-start 2env)) (source-path-form-number (node-source-path (lambda-bind fun))) (label-position (block-label (lambda-block fun))) - (when (ir2-physenv-closure-save-tn 2env) - (tn-sc+offset (ir2-physenv-closure-save-tn 2env))) + (when (ir2-environment-closure-save-tn 2env) + (tn-sc+offset (ir2-environment-closure-save-tn 2env))) #+unwind-to-frame-and-call-vop - (when (ir2-physenv-bsp-save-tn 2env) - (tn-sc+offset (ir2-physenv-bsp-save-tn 2env))) + (when (ir2-environment-bsp-save-tn 2env) + (tn-sc+offset (ir2-environment-bsp-save-tn 2env))) #-fp-and-pc-standard-save - (label-position (ir2-physenv-lra-saved-pc 2env)) + (label-position (ir2-environment-lra-saved-pc 2env)) #-fp-and-pc-standard-save - (label-position (ir2-physenv-cfp-saved-pc 2env)))))) + (label-position (ir2-environment-cfp-saved-pc 2env)))))) ;;; Return a complete C-D-F structure for FUN. This involves ;;; determining the DEBUG-INFO level and filling in optional slots as @@ -763,8 +763,8 @@ (eq start (ir2-block-last-vop 2block)) (eq (vop-name start) 'note-environment-start) next - (neq (ir2-block-physenv 2block) - (ir2-block-physenv next))))) + (neq (ir2-block-environment 2block) + (ir2-block-environment next))))) ;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be ;;; called after assembly so that source map information is available. diff -Nru sbcl-2.1.1/src/compiler/debug.lisp sbcl-2.1.11/src/compiler/debug.lisp --- sbcl-2.1.1/src/compiler/debug.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/debug.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -498,6 +498,11 @@ (dolist (exit (entry-exits node)) (unless (node-deleted exit) (check-node-reached node)))) + (enclose + (dolist (fun (enclose-funs node)) + (let ((enclose (functional-enclose fun))) + (unless (eq node enclose) + (barf "~S is not the ENCLOSE for its FUN ~S." node enclose))))) (exit (let ((entry (exit-entry node)) (value (exit-value node))) @@ -779,13 +784,13 @@ ;;; TNs to access the full call passing locations. (defun check-environment-lifetimes (component) (dolist (fun (component-lambdas component)) - (let* ((env (lambda-physenv fun)) - (2env (physenv-info env)) + (let* ((env (lambda-environment fun)) + (2env (environment-info env)) (vars (lambda-vars fun)) - (closure (ir2-physenv-closure 2env)) - (pc (ir2-physenv-return-pc-pass 2env)) - (fp (ir2-physenv-old-fp 2env)) - (2block (block-info (lambda-block (physenv-lambda env))))) + (closure (ir2-environment-closure 2env)) + (pc (ir2-environment-return-pc-pass 2env)) + (fp (ir2-environment-old-fp 2env)) + (2block (block-info (lambda-block (environment-lambda env))))) (do ((conf (ir2-block-global-tns 2block) (global-conflicts-next-blockwise conf))) ((null conf)) @@ -914,14 +919,19 @@ (constant (format stream "'~S" (constant-value leaf))) (global-var (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf))) + (clambda + (format stream "lambda ~@[~S ~]~:S" + (and (leaf-has-source-name-p leaf) + (functional-debug-name leaf)) + (mapcar #'leaf-debug-name (lambda-vars leaf)))) + (optional-dispatch + (format stream "optional-dispatch ~S" (mapcar #'leaf-debug-name (optional-dispatch-arglist leaf)))) (functional - (format stream "~S ~S ~S" (type-of leaf) (functional-debug-name leaf) - (mapcar #'leaf-debug-name - (typecase leaf - (clambda - (lambda-vars leaf)) - (optional-dispatch - (optional-dispatch-arglist leaf)))))))) + (case (functional-kind leaf) + (:toplevel-xep + (format stream "TL-XEP ~S" (entry-info-name (leaf-info leaf)))) + (t + (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf))))))) ;;; Attempt to find a block given some thing that has to do with it. (declaim (ftype (sfunction (t) cblock) block-or-lose)) @@ -947,7 +957,11 @@ (values)) (defun print-lvar (cont) (declare (type lvar cont)) - (format t "v~D " (cont-num cont)) + (if (and (lvar-info cont) + (eq (ir2-lvar-kind (lvar-info cont)) + :unknown)) + (format t "uv~D " (cont-num cont)) + (format t "v~D " (cont-num cont))) (values)) (defun print-lvar-stack (stack &optional (stream *standard-output*)) @@ -955,6 +969,8 @@ do (format stream "~:[u~;d~]v~D~@[ ~]" (lvar-dynamic-extent lvar) (cont-num lvar) rest))) +(defvar *debug-print-types* nil) + ;;; Print out the nodes in BLOCK in a format oriented toward ;;; representing what the code does. (defun print-nodes (block) @@ -1018,10 +1034,14 @@ ((:dynamic-extent) (format t "entry DX~{ v~D~}" (mapcar (lambda (lvar-or-cell) - (if (consp lvar-or-cell) - (cons (car lvar-or-cell) - (cont-num (cdr lvar-or-cell))) - (cont-num lvar-or-cell))) + (typecase lvar-or-cell + (cons + (cons (car lvar-or-cell) + (cont-num (cdr lvar-or-cell)))) + (enclose + lvar-or-cell) + (t + (cont-num lvar-or-cell)))) (cleanup-info cleanup)))) (t (format t "entry ~S" (entry-exits node)))))) @@ -1034,14 +1054,24 @@ (format t "exit ")) (t (format t "exit "))))) + (delay + (write-string "delay ") + (print-lvar (delay-value node))) (cast (let ((value (cast-value node))) (format t "cast v~D ~A[~S -> ~S]" (cont-num value) (if (cast-%type-check node) #\+ #\-) (cast-type-to-check node) (cast-asserted-type node)))) - (no-op - (princ "no-op"))) + (enclose + (write-string "enclose ") + (dolist (leaf (enclose-funs node)) + (print-leaf leaf) + (write-char #\space)))) + (when (and *debug-print-types* + (valued-node-p node)) + (write-char #\space) + (princ (type-specifier (node-derived-type node)))) (pprint-newline :mandatory))) (awhen (block-info block) @@ -1067,7 +1097,13 @@ (format stream "t~D" (tn-id tn)))) (when (and (tn-sc tn) (tn-offset tn)) (format stream "[~A]" (location-print-name tn))) - (format stream " ~s" (tn-kind tn)))) + (format stream " ~s~@[ ~a~]~@[ ~a~]" (tn-kind tn) + (and *debug-print-types* + (and (tn-sc tn) + (sc-name (tn-sc tn)))) + (and *debug-print-types* + (and (tn-primitive-type tn) + (primitive-type-name (tn-primitive-type tn))))))) ;;; Print the TN-REFs representing some operands to a VOP, linked by ;;; TN-REF-ACROSS. @@ -1109,7 +1145,7 @@ ;; depending on the call context. Resetting depth to 0 seems ;; like the best way to get consistent output. ;; We shouldn't bind the printer limits to NIL, because - ;; hairy internal objects such as PHYSENV can be printed. + ;; hairy internal objects such as ENVIRONMENT can be printed. ;; See also the comment above FUNCALL-WITH-DEBUG-IO-SYNTAX. (let (#-sb-xc-host (*current-level-in-print* 0) (*print-level* 2) @@ -1290,31 +1326,100 @@ (vop (ir2-block-start-vop block) (vop-next vop))) ((= i n) vop)))) +(defun show-transform-p (showp fun-name) + (or (and (listp showp) (member fun-name showp :test 'equal)) + (eq showp t))) + +(defun show-transform (kind name new-form &optional combination) + (let ((*print-length* 100) + (*print-level* 50) + (*print-right-margin* 128)) + (format *trace-output* "~&xform (~a) ~S ~% -> ~S~%" + kind + (if combination + (cons name + (loop for arg in (combination-args combination) + collect (if (constant-lvar-p arg) + (lvar-value arg) + (type-specifier (lvar-type arg))))) + name) + new-form))) + +(defun show-type-derivation (combination type) + (let ((*print-length* 100) + (*print-level* 50) + (*print-right-margin* 128)) + (unless (type= (node-derived-type combination) + (coerce-to-values type)) + (format *trace-output* "~&~a derived to ~a" + (cons (combination-fun-source-name combination) + (loop for arg in (combination-args combination) + collect (if (constant-lvar-p arg) + (lvar-value arg) + (type-specifier (lvar-type arg))))) + (type-specifier type))))) + +;;;; producing a graphviz file + +(defun replace-all (string part replacement &key (test #'char=)) + "Returns a new string in which all the occurences of the part +is replaced with replacement." + (with-output-to-string (out) + (loop with part-length = (length part) + for old-pos = 0 then (+ pos part-length) + for pos = (search part string + :start2 old-pos + :test test) + do (write-string string out + :start old-pos + :end (or pos (length string))) + when pos do (write-string replacement out) + while pos))) + (defun ir1-to-dot (component output-file) (with-open-file (stream output-file :if-exists :supersede :if-does-not-exist :create :direction :output) (write-line "digraph G {" stream) - (do-blocks (block component) - (when (typep (block-out block) '(cons (eql :graph) cons)) - (format stream "~a[style=filled color=~a];~%" - (block-number block) - (case (cadr (block-out block)) - (:marked "green") - (:remarked "aquamarine") - (:start "lightblue") - (:end "red")))) - (let ((succ (block-pred block))) - (when succ - (loop for succ in succ - for attr = "[style=bold]" then "" - do - (format stream "~a -> ~a~a;~%" - (block-number block) - (block-number succ) - attr))) - (when (nle-block-p block) - (format stream "~a -> ~a [style=dotted];~%" - (block-number block) - (block-number (nle-block-entry-block block)))))) + (write-line "node [fontname = \"monospace\"];" stream) + (write-line "node [shape=box];" stream) + ;; Give a unique label to every block, since BLOCK-NUMBERs may be + ;; uninitialized during optimization. + (let ((label 0) + (block-labels (make-hash-table :test #'eq))) + (do-blocks (block component :both) + (setf (gethash block block-labels) label) + (incf label)) + (flet ((block-label (block) + (gethash block block-labels))) + (do-blocks (block component :both) + (cond ((eq block (component-head component)) + (format stream "~a [label=head];" + (block-label block))) + ((eq block (component-tail component)) + (format stream "~a [label=tail];" + (block-label block))) + (t + (format stream "~a [label=\"~a\"];~%" + (block-label block) + (replace-all + (replace-all (with-output-to-string (*standard-output*) + (print-nodes block)) + (string #\Newline) + "\\l") + "\"" + "\\")))) + (let ((succ (block-succ block))) + (when succ + (loop for succ in succ + for attr = "[style=bold]" then "" + do + (format stream "~a -> ~a~a;~%" + (block-label block) + (block-label succ) + attr))) + (when (nle-block-p block) + (format stream "~a -> ~a [style=dotted];~%" + (block-label block) + (block-label (nle-block-entry-block block)))))))) (write-line "}" stream))) diff -Nru sbcl-2.1.1/src/compiler/deftype.lisp sbcl-2.1.11/src/compiler/deftype.lisp --- sbcl-2.1.1/src/compiler/deftype.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/deftype.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -9,10 +9,6 @@ (in-package "SB-IMPL") -;;; Has the type system been properly initialized? (I.e. is it OK to -;;; use it?) -(!define-load-time-global *type-system-initialized* nil) - (defun constant-type-expander (name expansion) (declare (optimize safety)) ;; Dummy implementation of SET-CLOSURE-NAME for the host. @@ -59,5 +55,46 @@ #+(and (not sb-doc) sb-xc-host) (setq doc nil) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (%compiler-deftype ',name ,expander-form ,source-location-form - ,@(when doc `(,doc))))))) + (%deftype ',name ,expander-form ,source-location-form + ,@(when doc `(,doc))))))) + +(defun %deftype (name expander source-location &optional doc) + (declare (ignorable doc)) + (with-single-package-locked-error + (:symbol name "defining ~A as a type specifier")) + (ecase (info :type :kind name) + (:primitive + ;; Detecting illegal redefinition in the cross-compiler + ;; adds unnecessary complexity, so don't bother. + #-sb-xc-host + (when *type-system-initialized* + (error "illegal to redefine standard type: ~S" name))) + (:instance + (warn "The class ~S is being redefined to be a DEFTYPE." name) + (undeclare-structure (find-classoid name) t) + ;; FIXME: shouldn't this happen only at eval-time? + (setf (classoid-cell-classoid (find-classoid-cell name :create t)) nil) + (clear-info :type :compiler-layout name) + (setf (info :type :kind name) :defined)) + (:defined + ;; Note: It would be nice to warn here when a type is being + ;; incompatibly redefined, but it's hard to tell, since type + ;; expanders are often function objects which can't easily be + ;; compared for equivalence. And just warning on redefinition + ;; isn't good, since DEFTYPE necessarily does its thing once at + ;; compile time and again at load time, so that it's very common + ;; and normal for types to be defined twice. So since there + ;; doesn't seem to be anything simple and obvious to do, and + ;; since mistakenly redefining a type isn't a common error + ;; anyway, we just don't worry about trying to warn about it. + ) + ((nil :forthcoming-defclass-type) + (setf (info :type :kind name) :defined))) + (setf (info :type :expander name) expander) + (when source-location + (setf (info :type :source-location name) source-location)) + #-sb-xc-host + (when doc + (setf (documentation name 'type) doc)) + (sb-c::%note-type-defined name) + name) diff -Nru sbcl-2.1.1/src/compiler/dfo.lisp sbcl-2.1.11/src/compiler/dfo.lisp --- sbcl-2.1.1/src/compiler/dfo.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/dfo.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -93,7 +93,7 @@ (dolist (succ (block-succ block)) (find-dfo-aux succ head component)) (when (component-nlx-info-generated-p component) - ;; FIXME: We also need (and do) this walk before physenv + ;; FIXME: We also need (and do) this walk before environment ;; analysis, but at that time we are probably not very ;; interested in the actual DF order. ;; @@ -200,10 +200,10 @@ ;;; If CLAMBDA is already in COMPONENT, just return that ;;; component. Otherwise, move the code for CLAMBDA and all lambdas it -;;; physically depends on (either because of calls or because of -;;; closure relationships) into COMPONENT, or possibly into another -;;; COMPONENT that we find to be related. Return whatever COMPONENT we -;;; actually merged into. +;;; depends on (either because of calls or because of closure +;;; relationships) into COMPONENT, or possibly into another COMPONENT +;;; that we find to be related. Return whatever COMPONENT we actually +;;; merged into. ;;; ;;; (Note: The analogous CMU CL code only scavenged call-based ;;; dependencies, not closure dependencies. That seems to've been by @@ -277,8 +277,8 @@ ;; CLAMBDA, then the home lambda should be in the ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU ;; CL, didn't do this, leading to the occasional - ;; failure when physenv analysis, which is local to - ;; each component, would bogusly conclude that a + ;; failure when environment analysis, which is local + ;; to each component, would bogusly conclude that a ;; closed-over variable was unused and thus delete ;; it. See e.g. cmucl-imp 2001-11-29.) (scavenge-closure-var (var) @@ -424,7 +424,7 @@ (setf (functional-kind lambda) :deleted) (dolist (let (lambda-lets lambda)) (setf (lambda-home let) result-lambda) - (setf (lambda-physenv let) (lambda-physenv result-lambda)) + (setf (lambda-environment let) (lambda-environment result-lambda)) (push let (lambda-lets result-lambda))) (setf (lambda-entries result-lambda) (nconc (lambda-entries result-lambda) diff -Nru sbcl-2.1.1/src/compiler/dump.lisp sbcl-2.1.11/src/compiler/dump.lisp --- sbcl-2.1.1/src/compiler/dump.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/dump.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -190,6 +190,9 @@ (hash (word-mix (length x) widetag))) (declare (word hash)) (dotimes (i n-data-words (logand hash most-positive-fixnum)) + ;; FIXME: the last word of {1,2,4}-bit-per-element vectors + ;; needs to be masked. At worst, this fails to coalesce + ;; similar vectors, so it's not fatal. (setq hash (word-mix hash (%vector-raw-bits x i)))))) (character (char-code x)) (t 0)))) @@ -448,8 +451,8 @@ ((not (similar-check-table x file)) (dump-list x file t) (similar-save-object x file)))) - (layout - (dump-layout x file) + (wrapper + (dump-wrapper x file) (eq-save-object x file)) #+sb-xc-host (ctype @@ -464,7 +467,7 @@ (t (bug "Bogus debug name marker"))))) (instance (let ((c (gethash x (sb-c::eql-constants sb-c::*ir1-namespace*)))) - (cond ((and c (neq (sb-c::leaf-%source-name c) 'sb-c::.anonymous.)) + (cond ((and c (sb-c::leaf-has-source-name-p c)) (dump-load-time-symbol-global-value c file)) (t (dump-structure x file) @@ -529,7 +532,9 @@ (dump-non-immediate-object x file))) ((fixnump x) (dump-integer x file)) ((characterp x) - (dump-fop 'fop-character file (sb-xc:char-code x))) + (dump-fop 'fop-character file (char-code x))) + ((packagep x) + (dump-push (dump-package x file) file)) #-sb-xc-host ((system-area-pointer-p x) (dump-fop 'fop-word-pointer file) @@ -573,6 +578,7 @@ ;;; We peek at the object type so that we only pay the circular ;;; detection overhead on types of objects that might be circular. (defun dump-object (x file) + #+(and metaspace sb-xc-host) (when (cl:typep x 'sb-vm:layout) (error "can't dump sb-vm:layout")) (if (compound-object-p x) (let ((*circularities-detected* ()) (circ (fasl-output-circularity-table file))) @@ -913,9 +919,11 @@ #-sb-xc-host (declare (type (simple-unboxed-array (*)) vector)) (let* ((length (length vector)) (widetag (%other-pointer-widetag vector)) - (bits-per-length (aref **saetp-bits-per-length** widetag))) - (aver (< bits-per-length 255)) + (bits-per-elt (sb-vm::simple-array-widetag->bits-per-elt widetag))) (unless data-only + ;; fop-spec-vector doesn't grok trailing #\null convention. + (aver (and (/= widetag sb-vm:simple-base-string-widetag) + (/= widetag sb-vm:simple-vector-widetag))) (dump-fop 'fop-spec-vector file length) (dump-byte widetag file)) @@ -930,8 +938,8 @@ (sb-impl::buffer-output (fasl-output-stream file) vector 0 - (ceiling (* length bits-per-length) sb-vm:n-byte-bits) - #+sb-xc-host bits-per-length)))) + (ceiling (* length bits-per-elt) sb-vm:n-byte-bits) + #+sb-xc-host bits-per-elt)))) ;;; Dump string-ish things. @@ -940,9 +948,9 @@ (declare (type simple-string s)) (if (or base-string-p #-sb-unicode t) ; if non-unicode, every char is 1 byte (dovector (c s) - (dump-byte (sb-xc:char-code c) fasl-output)) + (dump-byte (char-code c) fasl-output)) (dovector (c s) ; varint (a/k/a LEB128) is better for this than UTF-8. - (dump-varint (sb-xc:char-code c) fasl-output)))) + (dump-varint (char-code c) fasl-output)))) ;;; If we get here, it is assumed that the symbol isn't in the table, ;;; but we are responsible for putting it there when appropriate. @@ -1009,7 +1017,7 @@ (defconstant-eqx +fixup-flavors+ #(:assembly-routine :assembly-routine* :asm-routine-nil-offset - :symbol-tls-index + :gc-barrier :symbol-tls-index :foreign :foreign-dataref :code-object :layout :immobile-symbol :named-call :static-call :symbol-value @@ -1052,10 +1060,16 @@ flavor)) (operand (ecase flavor - (:code-object (the null name)) + ((:code-object :gc-barrier) (the null name)) (:layout - (if (symbolp name) name (layout-classoid-name name))) - (:layout-id (the layout name)) + (if (symbolp name) + name + (wrapper-classoid-name + (cond #+metaspace + ((sb-kernel::layout-p name) (layout-friend name)) + (t name))))) + (:layout-id + (the wrapper name)) ((:assembly-routine :assembly-routine* :asm-routine-nil-offset :symbol-tls-index ;; Only #+immobile-space can use the following two flavors. @@ -1088,7 +1102,7 @@ ;;; constants. ;;; ;;; We dump trap objects in any unused slots or forward referenced slots. -(defun dump-code-object (component code-segment code-length fixups fasl-output) +(defun dump-code-object (component code-segment code-length fixups alloc-points fasl-output) (declare (type component component) (type index code-length) (type fasl-output fasl-output)) @@ -1097,6 +1111,7 @@ (constants (sb-c:ir2-component-constants 2comp)) (header-length (length constants)) (n-named-calls 0)) + (dump-object alloc-points fasl-output) (collect ((patches)) ;; Dump the constants, noting any :ENTRY constants that have to ;; be patched. @@ -1104,10 +1119,15 @@ (let ((entry (aref constants i))) (etypecase entry (constant - (let ((name (sb-c::leaf-%source-name entry))) - (if (eq name 'sb-c::.anonymous.) - (dump-object (sb-c::constant-value entry) fasl-output) - (dump-load-time-symbol-global-value entry fasl-output)))) + (if (and (sb-c::leaf-has-source-name-p entry) + ;; We can't really reference constants defined + ;; by name at load time in the same block + ;; compilation unit, so dump it anonymously when + ;; such a situation arises. + (not (member (sb-c::leaf-source-name entry) + sb-c::*hairy-defconstants*))) + (dump-load-time-symbol-global-value entry fasl-output) + (dump-object (sb-c::constant-value entry) fasl-output))) (cons (ecase (car entry) (:constant ; anything that has not been wrapped in a # @@ -1148,6 +1168,9 @@ code-length n-fixups) ;; Fasl dumper/loader convention allows at most 3 integer args. ;; Others have to be written with explicit calls. + (dump-integer-as-n-bytes (length (sb-c::ir2-component-entries 2comp)) + 4 ; output 4 bytes + fasl-output) (dump-integer-as-n-bytes (the (unsigned-byte 22) n-named-calls) 4 ; output 4 bytes fasl-output) @@ -1162,8 +1185,9 @@ ;;; This is only called from assemfile, which doesn't exist in the target. #+sb-xc-host -(defun dump-assembler-routines (code-segment octets fixups routines file) +(defun dump-assembler-routines (code-segment octets fixups alloc-points routines file) (let ((n-fixups (dump-fixups fixups file))) + (dump-object alloc-points file) ;; The name -> address table has to be created before applying fixups ;; because a fixup may refer to an entry point in the same code component. ;; So these go on the stack last, i.e. nearest the top. @@ -1192,11 +1216,7 @@ ;;; Dump the code, constants, etc. for component. We pass in the ;;; assembler fixups, code vector and node info. -(defun fasl-dump-component (component - code-segment - code-length - fixups - file) +(defun fasl-dump-component (component code-segment code-length fixups alloc-points file) (declare (type component component)) (declare (type fasl-output file)) @@ -1219,7 +1239,7 @@ (dolist (entry entries) ;; Process in reverse order of ENTRIES. ;; See also MAKE-CORE-COMPONENT which does the same thing. - (decf wordindex 4) + (decf wordindex sb-vm:code-slots-per-simple-fun) (setf (aref constants (+ wordindex sb-vm:simple-fun-name-slot)) `(:constant ,(sb-c::entry-info-name entry)) (aref constants (+ wordindex sb-vm:simple-fun-arglist-slot)) @@ -1228,7 +1248,8 @@ `(:constant ,(sb-c::entry-info-form/doc entry)) (aref constants (+ wordindex sb-vm:simple-fun-info-slot)) `(:constant ,(sb-c::entry-info-type/xref entry)))) - (dump-code-object component code-segment code-length fixups file))) + (dump-code-object component code-segment code-length fixups + alloc-points file))) (fun-index nfuns)) (dolist (entry entries) @@ -1241,10 +1262,7 @@ ;; to functions in top-level forms. #+sb-xc-host (let ((name (sb-c::entry-info-name entry))) - ;; At the moment, we rely on the fopcompiler to do linking - ;; for DEFUNs that are not block compiled. - (when (and (eq (sb-c::block-compile sb-c::*compilation*) t) - (sb-c::legal-fun-name-p name)) + (when (sb-c::legal-fun-name-p name) (dump-object name file) (dump-push entry-handle file) (dump-fop 'fop-fset file))) @@ -1318,12 +1336,12 @@ struct)) (note-potential-circularity struct file) (do* ((length (%instance-length struct)) - (layout (%instance-layout struct)) - (bitmap (layout-bitmap layout)) + (wrapper (%instance-wrapper struct)) + (bitmap (wrapper-bitmap wrapper)) (circ (fasl-output-circularity-table file)) (index sb-vm:instance-data-start (1+ index))) ((>= index length) - (dump-non-immediate-object layout file) + (dump-non-immediate-object wrapper file) (dump-fop 'fop-struct file length)) (let* ((obj (if (logbitp index bitmap) (%instance-ref struct index) @@ -1340,14 +1358,14 @@ (t obj)) file)))) -(defun dump-layout (obj file) - (when (layout-invalid obj) +(defun dump-wrapper (obj file &aux (flags (wrapper-flags obj))) + (when (wrapper-invalid obj) (compiler-error "attempt to dump reference to obsolete class: ~S" - (layout-classoid obj))) + (wrapper-classoid obj))) ;; STANDARD-OBJECT could in theory be dumpable, but nothing else, ;; because all its subclasses can evolve to have new layouts. - (aver (not (logtest (layout-flags obj) +pcl-object-layout-flag+))) - (let ((name (layout-classoid-name obj))) + (aver (not (logtest flags +pcl-object-layout-flag+))) + (let ((name (wrapper-classoid-name obj))) ;; Q: Shouldn't we aver that NAME is the proper name for its classoid? (unless name (compiler-error "dumping anonymous layout: ~S" obj)) @@ -1357,11 +1375,11 @@ #-sb-xc-host (let ((fop (known-layout-fop name))) (when fop - (return-from dump-layout (dump-byte fop file)))) + (return-from dump-wrapper (dump-byte fop file)))) (dump-object name file)) - (sub-dump-object (layout-bitmap obj) file) - (sub-dump-object (layout-inherits obj) file) + (sub-dump-object (wrapper-bitmap obj) file) + (sub-dump-object (wrapper-inherits obj) file) (dump-fop 'fop-layout file - (1+ (layout-depthoid obj)) ; non-stack args can't be negative - (logand (layout-flags obj) sb-kernel::layout-flags-mask) - (layout-length obj))) + (1+ (wrapper-depthoid obj)) ; non-stack args can't be negative + (logand flags sb-kernel::layout-flags-mask) + (wrapper-length obj))) diff -Nru sbcl-2.1.1/src/compiler/early-c.lisp sbcl-2.1.11/src/compiler/early-c.lisp --- sbcl-2.1.1/src/compiler/early-c.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/early-c.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -40,18 +40,6 @@ ;;;; miscellaneous types used both in the cross-compiler and on the target -;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong -;;;; somewhere else, not "early-c", since they're after all not part -;;;; of the compiler. - -;;; the type of LAYOUT-DEPTHOID and LAYOUT-LENGTH values. -;;; Each occupies two bytes of the %BITS slot when possible, -;;; otherwise a slot unto itself. -(def!type layout-depthoid () '(integer -1 #x7FFF)) -(def!type layout-length () '(integer 0 #xFFFF)) -(def!type layout-bitmap () 'integer) -;;; ID must be an fixnum for either value of n-word-bits. -(def!type layout-id () '(signed-byte 30)) ;;; An INLINEP value describes how a function is called. The values ;;; have these meanings: @@ -121,12 +109,11 @@ ;;; Bind this to a stream to capture various internal debugging output. (defvar *compiler-trace-output* nil) ;;; These are the default, but the list can also include -;;; :pre-ir2-optimize and :symbolic-asm. +;;; :pre-ir2-optimize, :symbolic-asm, and :sb-graph. (defvar *compile-trace-targets* '(:ir1 :ir2 :vop :symbolic-asm :disassemble)) (defvar *constraint-universe*) (defvar *current-path*) (defvar *current-component*) -(defvar *delayed-ir1-transforms*) #+sb-dyncount (defvar *dynamic-counts-tn*) (defvar *elsewhere-label*) @@ -141,6 +128,9 @@ (defvar *compile-object* nil) (defvar *location-context* nil) +(defvar *handled-conditions* nil) +(defvar *disabled-package-locks* nil) + (defvar *stack-allocate-dynamic-extent* t "If true (the default), the compiler respects DYNAMIC-EXTENT declarations and stack allocates otherwise inaccessible parts of the object whenever @@ -154,94 +144,21 @@ (declaim (type (member nil t :specified) *block-compile-default* *block-compile-argument*)) -;;; This lock is seized in the compiler, and related areas -- like the -;;; classoid/layout/class system. -;;; Assigning a literal object enables genesis to dump and load it -;;; without need of a cold-init function. -#-sb-xc-host -(!define-load-time-global **world-lock** (sb-thread:make-mutex :name "World Lock")) +;; Names seen which are defined to be hairy (i.e. non-EQ comparable) +;; constants. +(defvar *hairy-defconstants* '()) +(declaim (type list *hairy-defconstants*)) #-sb-xc-host (define-load-time-global *static-linker-lock* (sb-thread:make-mutex :name "static linker")) -(defmacro with-world-lock (() &body body) - #+sb-xc-host `(progn ,@body) - #-sb-xc-host `(sb-thread:with-recursive-lock (**world-lock**) ,@body)) ;;;; miscellaneous utilities -;;; This is for "observers" who want to know if type names have been added. -;;; Rather than registering listeners, they can detect changes by comparing -;;; their stored nonce to the current nonce. Additionally the observers -;;; can detect whether function definitions have occurred. -#-sb-xc-host -(progn (declaim (fixnum *type-cache-nonce*)) - (!define-load-time-global *type-cache-nonce* 0)) - -(defstruct (undefined-warning - (:print-object (lambda (x s) - (print-unreadable-object (x s :type t) - (prin1 (undefined-warning-name x) s)))) - (:copier nil)) - ;; the name of the unknown thing - (name nil :type (or symbol list)) - ;; the kind of reference to NAME - (kind (missing-arg) :type (member :function :type :variable)) - ;; the number of times this thing was used - (count 0 :type unsigned-byte) - ;; a list of COMPILER-ERROR-CONTEXT structures describing places - ;; where this thing was used. Note that we only record the first - ;; *UNDEFINED-WARNING-LIMIT* calls. - (warnings () :type list)) -(declaim (freeze-type undefined-warning)) - -;;; Delete any undefined warnings for NAME and KIND. This is for the -;;; benefit of the compiler, but it's sometimes called from stuff like -;;; type-defining code which isn't logically part of the compiler. -(declaim (ftype (function ((or symbol cons) keyword) (values)) - note-name-defined)) -(defun note-name-defined (name kind) - #-sb-xc-host (atomic-incf *type-cache-nonce*) - ;; We do this BOUNDP check because this function can be called when - ;; not in a compilation unit (as when loading top level forms). - (when (boundp '*undefined-warnings*) - (let ((name (uncross name))) - (setq *undefined-warnings* - (delete-if (lambda (x) - (and (equal (undefined-warning-name x) name) - (eq (undefined-warning-kind x) kind))) - *undefined-warnings*)))) - (values)) - -;;; to be called when a variable is lexically bound -(declaim (ftype (function (symbol) (values)) note-lexical-binding)) -(defun note-lexical-binding (symbol) - ;; This check is intended to protect us from getting silently - ;; burned when we define - ;; foo.lisp: - ;; (DEFVAR *FOO* -3) - ;; (DEFUN FOO (X) (+ X *FOO*)) - ;; bar.lisp: - ;; (DEFUN BAR (X) - ;; (LET ((*FOO* X)) - ;; (FOO 14))) - ;; and then we happen to compile bar.lisp before foo.lisp. - (when (looks-like-name-of-special-var-p symbol) - ;; FIXME: should be COMPILER-STYLE-WARNING? - (style-warn 'asterisks-around-lexical-variable-name - :format-control - "using the lexical binding of the symbol ~ - ~/sb-ext:print-symbol-with-prefix/, not the~@ - dynamic binding" - :format-arguments (list symbol))) - (values)) - -;;; This is DEF!STRUCT so that when SB-C:DUMPABLE-LEAFLIKE-P invokes -;;; SB-XC:TYPEP in make-host-2, it does not need need to signal PARSE-UNKNOWN -;;; for each and every constant seen up until this structure gets defined. -(def!struct (debug-name-marker (:print-function print-debug-name-marker) - (:copier nil))) +(defstruct (debug-name-marker (:print-function print-debug-name-marker) + (:copier nil))) +(declaim (freeze-type debug-name-marker)) (defvar *debug-name-level* 4) (defvar *debug-name-length* 12) @@ -285,6 +202,8 @@ ((or symbol number string) x) (t + ;; wtf?? This looks like a source of sensitivity to the cross-compiler host + ;; in addition to which it seems generally a stupid idea. (type-of x))))) (let ((name (list* type (walk thing) (when context (name-context))))) (when (legal-fun-name-p name) @@ -396,7 +315,7 @@ (objmap-id-to-ir2block nil :type (or null id-array)) ; number -> IR2-BLOCK (objmap-id-to-tn nil :type (or null id-array)) ; number -> TN (objmap-id-to-label nil :type (or null id-array)) ; number -> LABEL - ) + deleted-source-paths) (declaim (freeze-type compilation)) (sb-impl::define-thread-local *compilation*) diff -Nru sbcl-2.1.1/src/compiler/early-constantp.lisp sbcl-2.1.11/src/compiler/early-constantp.lisp --- sbcl-2.1.1/src/compiler/early-constantp.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/early-constantp.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -13,7 +13,7 @@ ;;; Subtypes of this show up as the environment argument to inquiry functions. (defstruct (abstract-lexenv - (:constructor nil) (:copier nil) (:predicate nil))) + (:constructor nil) (:copier nil) (:predicate nil))) (declaim (inline constantp)) (defun constantp (form &optional (environment nil envp)) @@ -29,11 +29,3 @@ is undefined unless CONSTANTP has been first used to determine the constantness of the FORM in ENVIRONMENT." (%constant-form-value form environment envp)) - -(declaim (inline constant-typep)) -(defun constant-typep (form type &optional (environment nil envp)) - (and (%constantp form environment envp) - ;; FIXME: We probably should be passing the environment to - ;; TYPEP too, but (1) our XC version of typep AVERs that the - ;; environment is null (2) our real version ignores it anyhow. - (sb-xc:typep (%constant-form-value form environment envp) type))) diff -Nru sbcl-2.1.1/src/compiler/early-globaldb.lisp sbcl-2.1.11/src/compiler/early-globaldb.lisp --- sbcl-2.1.1/src/compiler/early-globaldb.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/early-globaldb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -35,6 +35,66 @@ #-sb-xc-host (declaim (ftype (sfunction (t) ctype) global-ftype)) +;;; A bit about the physical representation of the packed info format: +;;; With #+compact-instance-header it is possible to represent a vector of N things +;;; in a structure using (ALIGN-UP (1+ N) 2) words of memory. This is a saving +;;; of 1 word on average when compared to SIMPLE-VECTOR which needs +;;; (ALIGN-UP (+ N 2) 2) words. Granted that either might have a padding word, +;;; but I've observed 5% to 10% space reduction by eliminating one slot. +;;; Without compact-instance-header, we'e indifferent, in terms of space, +;;; as to whether this is an INSTANCE or a SIMPLE-VECTOR. For consistency, +;;; we use an INSTANCE regardless of presence of the compact-header feature. +;;; This makes assembly routines (e.g. CALL-SYMBOL) slightly less sensitive +;;; to the feature's absence. + +;;; Since variable-length instances aren't portably a thing, +;;; we use a structure of one slot holding a vector. +#+sb-xc-host (defstruct (packed-info + (:constructor %make-packed-info (cells)) + (:copier nil)) + ;; These objects are immutable. + (cells #() :type simple-vector :read-only t)) +;;; Some abstractions for host/target compatibility of all the defuns. +#+sb-xc-host +(progn + (defmacro make-packed-info (n) `(%make-packed-info (make-array ,n))) + (defmacro copy-packed-info (info) + `(%make-packed-info (copy-seq (packed-info-cells ,info)))) + (defmacro packed-info-len (info) + `(length (packed-info-cells ,info))) + (defmacro %info-ref (info index) `(svref (packed-info-cells ,info) ,index))) +#-sb-xc-host +(progn + #+nil + (defmethod print-object ((obj packed-info) stream) + (format stream "[~{~W~^ ~}]" + (loop for i below (%instance-length obj) + collect (%instance-ref obj i)))) + (defmethod print-object ((self sb-int:packed-info) stream) + (print-unreadable-object (self stream :type t :identity t) + (format stream "len=~d" (sb-kernel:%instance-length self)))) + (eval-when (:compile-toplevel) + (sb-xc:defmacro make-packed-info (n) + ;; this file is earlier than early-vm, so we have to take + ;; INSTANCE-DATA-START from the value set in make-host-1. + `(let ((new (%make-instance (+ ,n #.sb-vm:instance-data-start)))) + (setf (%instance-wrapper new) #.(find-layout 'packed-info)) + new)) + ;; We can't merely call COPY-STRUCTURE due to two issues: + ;; 1. bootstrapping- the DEFSTRUCT-DESCRIPTION is not available + ;; in cold-init by the first call to COPY-PACKED-INFO, + ;; but COPY-STRUCTURE needs it, because of raw slots. + ;; 2. the transform for COPY-STRUCTURE would think that + ;; it needs to copy exactly 1 slot. Well, it would think that, + ;; if the FREEZE-TYPE wasn't commented out. + (sb-xc:defmacro copy-packed-info (info) + ;; not bothering with ONCE-ONLY here (doesn't matter) + `(%copy-instance (%make-instance (%instance-length ,info)) ,info))) + (defmacro packed-info-len (info) + `(- (%instance-length ,info) sb-vm:instance-data-start)) + (defmacro %info-ref (v i) + `(%instance-ref ,v (+ ,i #.sb-vm:instance-data-start)))) + ;;; At run time, we represent the type of a piece of INFO in the globaldb ;;; by a small integer between 1 and 63. [0 is reserved for internal use.] ;;; CLISP, and maybe others, need EVAL-WHEN because without it, the constant @@ -46,9 +106,7 @@ ;;; A map from info-number to its META-INFO object. ;;; The reverse mapping is obtained by reading the META-INFO. (declaim (type (simple-vector #.(ash 1 info-number-bits)) *info-types*)) -(!define-load-time-global *info-types* - ;; Must be dumped as a literal for cold-load. - #.(make-array (ash 1 info-number-bits) :initial-element nil)) +(define-load-time-global *info-types* (make-array (ash 1 info-number-bits) :initial-element nil)) (defstruct (meta-info (:constructor @@ -87,25 +145,26 @@ ;;; presented at the definition of SYMBOL-PLIST, if the object in SYMBOL's ;;; info slot is LISTP, it is in state 1 or 3. Either way, take the CDR. ;;; Otherwise, it is in state 2 so return the value as-is. -;;; In terms of this function being named "-vector", implying always a vector, -;;; it is understood that NIL is a proxy for +NIL-PACKED-INFOS+, a vector. +;;; NIL is an acceptable substitute for +NIL-PACKED-INFOS+, +;;; but I might change that. ;;; -;;; Define SYMBOL-INFO-VECTOR as an inline function unless a vop translates it. +;;; Define SYMBOL-INFO as an inline function unless a vop translates it. ;;; (Inlining occurs first, which would cause the vop not to be used.) #-sb-xc-host -(sb-c::unless-vop-existsp (:translate sb-kernel:symbol-info-vector) - (declaim (inline symbol-info-vector)) - (defun symbol-info-vector (symbol) - (let ((info-holder (symbol-info symbol))) - (truly-the (or null simple-vector) +(sb-c::unless-vop-existsp (:translate sb-kernel:symbol-dbinfo) + (declaim (inline symbol-dbinfo)) + (defun symbol-dbinfo (symbol) + (let ((info-holder (symbol-%info symbol))) + (truly-the (or null instance) (if (listp info-holder) (cdr info-holder) info-holder))))) -;;; SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp' -;;; But in the host Lisp, there is no such thing as a symbol-info slot. -;;; Instead, symbol-info is kept in the host symbol's plist. -;;; This must be a SETFable place. +;;; %SYMBOL-INFO is a primitive object accessor defined in 'objdef.lisp' +;;; But in the host Lisp, there is no such thing. Instead, SYMBOL-%INFO +;;; is kept as a property on the host symbol. +;;; The compatible "primitive" accessor must be a SETFable place. #+sb-xc-host -(defmacro symbol-info-vector (symbol) `(get ,symbol :sb-xc-globaldb-info)) +(progn (defmacro symbol-%info (symbol) `(get ,symbol :sb-xc-globaldb-info)) + (defun symbol-dbinfo (symbol) (symbol-%info symbol))) ;; Perform the equivalent of (GET-INFO-VALUE KIND +INFO-METAINFO-TYPE-NUM+) ;; but skipping the defaulting logic. @@ -113,19 +172,21 @@ ;; - though not always - a unique identifier for the (:TYPE :KIND) pair. ;; Note that bypassing of defaults is critical for bootstrapping, ;; since INFO is used to retrieve its own META-INFO at system-build time. -(defmacro !get-meta-infos (kind) - `(let* ((info-vector (symbol-info-vector ,kind)) - (index (if info-vector - (packed-info-value-index info-vector +no-auxiliary-key+ +(defmacro get-meta-infos (kind) + `(let* ((packed-info (symbol-dbinfo ,kind)) + (index (if packed-info + (packed-info-value-index packed-info +no-auxiliary-key+ +info-metainfo-type-num+)))) - (if index (svref info-vector index)))) + (if index (%info-ref packed-info index)))) -;; (UNSIGNED-BYTE 16) is an arbitrarily generous limit on the number of -;; cells in an info-vector. Most vectors have a fewer than a handful of things, +;; (UNSIGNED-BYTE 11) is an arbitrarily generous limit on the number of +;; cells in a packed-info. Most packed-infos have fewer than a handful of things, ;; and performance would need to be re-thought if more than about a dozen ;; cells were in use. (It would want to become hash-based probably) -(declaim (ftype (function (simple-vector (or (eql 0) symbol) info-number) - (or null (unsigned-byte 16))) +;; It has to be smaller than INSTANCE_LENGTH_MASK certainly, +;; plus leaving room for a layout slot if #-compact-instance-header. +(declaim (ftype (function (packed-info (or (eql 0) symbol) info-number) + (or null (unsigned-byte 11))) packed-info-value-index)) ;; Return the META-INFO object for CATEGORY and KIND, signaling an error @@ -138,7 +199,7 @@ ;; through, whereas typically no more than 3 or 4 items have the same KIND. ;; (defun meta-info (category kind &optional (errorp t)) - (or (let ((metadata (!get-meta-infos kind))) + (or (let ((metadata (get-meta-infos kind))) (cond ((listp metadata) ; conveniently handles NIL (dolist (info metadata nil) ; FIND is slower :-( (when (eq (meta-info-category (truly-the meta-info info)) @@ -146,7 +207,7 @@ (return info)))) ((eq (meta-info-category (truly-the meta-info metadata)) category) metadata))) - ;; !GET-META-INFOS enforces that KIND is a symbol, therefore + ;; GET-META-INFOS enforces that KIND is a symbol, therefore ;; if a metaobject was found, CATEGORY was necessarily a symbol too. ;; Otherwise, if the caller wants no error to be signaled on missing info, ;; we must nevertheless enforce that CATEGORY was actually a symbol. @@ -184,10 +245,6 @@ .whole.))) .whole.)))) - ;; ECL bug workaround: INFO ceases to be a valid macrolet name - ;; because it tries to run the compiler-macro before the local macro. - ;; In particular, "(collect ((info)) ...)" will not compile correctly. - #-host-quirks-ecl (def info (category kind name) `(truly-the (values ,(meta-info-type-spec meta-info) boolean) (get-info-value ,name ,(meta-info-number meta-info)))) diff -Nru sbcl-2.1.1/src/compiler/early-lexenv.lisp sbcl-2.1.11/src/compiler/early-lexenv.lisp --- sbcl-2.1.1/src/compiler/early-lexenv.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/early-lexenv.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -;;;; This file contains early compiler-related structure definitions. - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-C") - -(defconstant-eqx +policy-primary-qualities+ - #(;; ANSI standard qualities - compilation-speed - debug - safety - space - speed - ;; SBCL extensions - ;; - ;; FIXME: INHIBIT-WARNINGS is a misleading name for this. - ;; Perhaps BREVITY would be better. But the ideal name would - ;; have connotations of suppressing not warnings but only - ;; optimization-related notes, which is already mostly the - ;; behavior, and should probably become the exact behavior. - ;; Perhaps INHIBIT-NOTES? - inhibit-warnings) - #'equalp) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant n-policy-primary-qualities (length +policy-primary-qualities+)) - ;; 1 bit per quality is stored to indicate whether it was explicitly given - ;; a value in a lexical policy. In addition to the 5 ANSI-standard qualities, - ;; SBCL defines one more "primary" quality and 16 dependent qualities. - ;; Both kinds take up 1 bit in the mask of specified qualities. - (defconstant max-policy-qualities 32)) - -;; Each primary and dependent quality policy is assigned a small integer index. -;; The POLICY struct represents a set of policies in an order-insensitive way -;; that facilitates quicker lookup than scanning an alist. -(defstruct (policy (:constructor make-policy - (primary-qualities &optional - presence-bits dependent-qualities))) - ;; Mask with a 1 for each quality that has an explicit value in this policy. - ;; Primary qualities fill the mask from left-to-right and dependent qualities - ;; from right-to-left. - ;; xc has trouble folding this MASK-FIELD, but it works when host-evaluated. - (presence-bits #.(mask-field - (byte n-policy-primary-qualities - (- max-policy-qualities n-policy-primary-qualities)) - -1) - :type (unsigned-byte #.max-policy-qualities)) - ;; For efficiency, primary qualities are segregated because there are few - ;; enough of them to fit in a fixnum. - (primary-qualities 0 :type (unsigned-byte #.(* 2 n-policy-primary-qualities))) - ;; 2 bits per dependent quality is a fixnum on 64-bit build, not on 32-bit. - ;; It would certainly be possible to constrain this to storing exactly - ;; the 16 currently defined dependent qualities, - ;; but that would be overly limiting. - (dependent-qualities 0 - :type (unsigned-byte #.(* (- max-policy-qualities n-policy-primary-qualities) - 2)))) -(declaim (freeze-type policy)) - -(defvar *handled-conditions* nil) -(defvar *disabled-package-locks* nil) - -;;; The LEXENV represents the lexical environment used for IR1 conversion. -;;; (This is also what shows up as an ENVIRONMENT value in macroexpansion.) -(declaim (inline internal-make-lexenv)) ; only called in one place -(defstruct (lexenv - (:include abstract-lexenv) - (:print-function - (lambda (lexenv stream depth) - (if (null-lexenv-p lexenv) - (print-unreadable-object (lexenv stream) - (write-string "NULL-LEXENV" stream)) - (default-structure-print lexenv stream depth)))) - (:copier nil) - (:constructor make-null-lexenv ()) - (:constructor make-almost-null-lexenv (%policy handled-conditions - flushable lambda parent)) - (:constructor make-package-lock-lexenv - (disabled-package-locks %policy - &aux (handled-conditions nil))) - (:constructor internal-make-lexenv - (funs vars blocks tags - type-restrictions - flushable - lambda cleanup handled-conditions - disabled-package-locks %policy user-data - parent))) - ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a - ;; local function), a DEFINED-FUN, representing an - ;; INLINE/NOTINLINE declaration, or a list (MACRO . ) (a - ;; local macro, with the specifier expander). Note that NAME may be - ;; a (SETF ) list, not necessarily a single symbol. - (funs nil :type list) - ;; an alist translating variable names to LEAF structures. A special - ;; binding is indicated by a :SPECIAL GLOBAL-VAR leaf. Each special - ;; binding within the code gets a distinct leaf structure, as does - ;; the current "global" value on entry to the code compiled. - ;; (locally (special ...)) is handled by adding the most recent - ;; special binding to the front of the list. - ;; - ;; If the CDR is (MACRO . ), then is the expansion of a - ;; symbol macro. - (vars nil :type list) - ;; BLOCKS and TAGS are alists from block and go-tag names to 2-lists - ;; of the form ( ), where is the - ;; continuation to exit to, and is the corresponding ENTRY - ;; node. - (blocks nil :type list) - (tags nil :type list) - ;; an alist (THING . CTYPE) which is used to keep track of - ;; "pervasive" type declarations. When THING is a leaf, this is for - ;; type declarations that pertain to the type in a syntactic extent - ;; which does not correspond to a binding of the affected name. - (type-restrictions nil :type list) - ;; the lexically enclosing lambda, if any - ;; - ;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard - ;; to get CLAMBDA defined in time for the cross-compiler. - (lambda nil) - ;; the lexically enclosing cleanup, or NIL if none enclosing within LAMBDA - (cleanup nil) - ;; condition types we handle with a handler around the compiler - (handled-conditions *handled-conditions*) - ;; lexically disabled package locks (list of symbols) - (disabled-package-locks *disabled-package-locks*) - ;; the current OPTIMIZE policy. this is null in the null environment, - ;; and the global policy is stored in *POLICY*. (Because we want to - ;; be able to affect it from :WITH-COMPILATION-UNIT.) NIL here also - ;; works as a convenient null-lexenv identifier. - (%policy nil :type (or null policy)) - ;; A list associating extra user info to symbols. The entries - ;; are of the form (:declare name . value), - ;; (:variable name key . value), or (:function name key . value) - (user-data nil :type list) - (parent nil) - ;; Cache of all visible variables, including the ones coming from - ;; (call-lexenv lambda) - ;; Used for LEAF-VISIBLE-TO-DEBUGGER-P - (var-cache nil :type (or null hash-table)) - ;; A list of functions that can be removed when unused. - ;; Similar to the FLUSHABLE attribute in DEFKNOWN, but can applied - ;; locally to things that are generally not flushable but can be - ;; flushed in some circumstances. - (flushable nil :type list)) - -;;; the lexical environment we are currently converting in -(defvar *lexenv*) -(declaim (type lexenv *lexenv*)) - -;;; an object suitable for input to standard functions that accept -;;; "environment objects" (of the ANSI glossary) -(def!type lexenv-designator () '(or abstract-lexenv null)) - -(defvar *policy*) -(defun lexenv-policy (lexenv) - (or (lexenv-%policy lexenv) *policy*)) - -(defun null-lexenv-p (lexenv) - (not (lexenv-%policy lexenv))) - - -;;; translation from template names to template structures -(defglobal *backend-template-names* (make-hash-table)) ; keys are symbols -(declaim (type hash-table *backend-template-names*)) - -;;; When compiling the cross-compiler, a %VOP-EXISTS-P result could depend on -;;; the build order. Usually it will not, because the decision to use a vop is -;;; typically made in a transform, so the query occurs only when a transform runs. -;;; However, sometimes the existsp check is performed to decide whether or not -;;; to define a function or other transform. In that case the existsp check is -;;; sensitive to the order of vop definitions. Such uses will often occur inside -;;; a "#." so that the defining form remains toplevel. -;;; If called with OPTIMISTIC = T then we're trying to return NIL or T -;;; or the EXISTSP macroexpander. -#+sb-xc-host -(progn - (defvar *vop-not-existsp* nil) - ;;; This function is invoked after compiling the cross-compiler - ;;; before quitting the image, and when loading it from compiled fasls - ;;; (because toplevel forms might use %VOP-EXISTSP at any time). - (defun check-vop-existence-correctness () - (dolist (entry *vop-not-existsp*) - (assert (not (%vop-existsp (car entry) (cdr entry)))))) - (defun %vop-existsp (name query &optional optimistic) - (declare (notinline info fun-info-templates)) - (let ((answer - (not (null (ecase query - (:named - (gethash name *backend-template-names*)) - (:translate - (awhen (info :function :info name) - (fun-info-templates it)))))))) - ;; Negatives won't be stored in the journal in optimistic mode. - (when (and (not answer) (not optimistic)) - (pushnew (cons name query) *vop-not-existsp* :test 'equal)) - answer))) - -(defmacro vop-existsp (query name) - #+sb-xc-host - (cond ((%vop-existsp name query t) - ;;(format t "~&VOP-EXISTSP ~s ~s: Yes~%" name query) - t) - (t - ;;(format t "~&VOP-EXISTSP ~s ~s: DEFER~%" name query) - `(%vop-existsp ',name ,query))) - ;; When running the cross-compiler, all the inquiries to VOP-EXISTSP have - ;; definitive answers, so this never defers. - ;; We use the version of %VOP-EXISTSP that was built in to the host. - #-sb-xc-host - (funcall '%vop-existsp name query)) - -;;; For situations where you want to write (IF (VOP-EXISTSP ...) (THEN) (ELSE)) -;;; but at least one of (THEN) or (ELSE) contains code that can't be macroexpanded -;;; or compiled, as may occur with (VOP* ...), use a different macro that never -;;; defers. Correctness of the result requires that the vop be defined in time. -(defmacro if-vop-existsp ((query name) then &optional else) - (if (funcall '%vop-existsp name query) then else)) -(defmacro when-vop-existsp ((query name) &rest body) - (if (funcall '%vop-existsp name query) `(progn ,@body))) -(defmacro unless-vop-existsp ((query name) &rest body) - (if (not (funcall '%vop-existsp name query)) `(progn ,@body))) diff -Nru sbcl-2.1.1/src/compiler/entry.lisp sbcl-2.1.11/src/compiler/entry.lisp --- sbcl-2.1.1/src/compiler/entry.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/entry.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -52,7 +52,7 @@ (let ((bind (lambda-bind fun)) (internal-fun (functional-entry-fun fun))) (setf (entry-info-closure-tn info) - (if (physenv-closure (lambda-physenv fun)) + (if (environment-closure (lambda-environment fun)) (make-normal-tn *backend-t-primitive-type*) nil)) (setf (entry-info-offset info) (gen-label)) @@ -112,12 +112,14 @@ (let ((spec (type-specifier (leaf-type internal-fun))) (result)) (setf (entry-info-type info) - (if (and (listp spec) - (typep (setq result (third spec)) - '(cons (eql values) - (cons t (cons (eql &optional) null))))) - `(sfunction ,(cadr spec) ,(cadr result)) - spec))))) + (constant-value + (find-constant + (if (and (listp spec) + (typep (setq result (third spec)) + '(cons (eql values) + (cons t (cons (eql &optional) null))))) + `(sfunction ,(cadr spec) ,(cadr result)) + spec))))))) (values)) ;;; Replace all references to COMPONENT's non-closure XEPs that appear @@ -154,7 +156,7 @@ ;; It may have been deleted due to none of ;; the optional entries reaching it. (neq (functional-kind main-entry) :deleted) - (physenv-closure (lambda-physenv main-entry))))) + (environment-closure (lambda-environment main-entry))))) (dolist (ref (leaf-refs lambda)) (let ((ref-component (node-component ref))) (cond ((eq ref-component component)) diff -Nru sbcl-2.1.1/src/compiler/envanal.lisp sbcl-2.1.11/src/compiler/envanal.lisp --- sbcl-2.1.1/src/compiler/envanal.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/compiler/envanal.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,595 @@ +;;;; This file implements the environment analysis phase for the +;;;; compiler. This phase annotates IR1 with a hierarchy environment +;;;; structures, determining the environment that each LAMBDA +;;;; allocates its variables and finding what values are closed over +;;;; by each environment. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-C") + +;;; Do environment analysis on the code in COMPONENT. This involves +;;; various things: +;;; 1. Make an ENVIRONMENT structure for each non-LET LAMBDA, assigning +;;; the LAMBDA-ENVIRONMENT for all LAMBDAs. +;;; 2. Find all values that need to be closed over by each +;;; environment. +;;; 3. Scan the blocks in the component closing over non-local-exit +;;; continuations. +;;; 4. Delete all non-top-level functions with no references. This +;;; should only get functions with non-NULL kinds, since normal +;;; functions are deleted when their references go to zero. +(defun environment-analyze (component) + (declare (type component component)) + (aver (every (lambda (x) + (eq (functional-kind x) :deleted)) + (component-new-functionals component))) + (setf (component-new-functionals component) ()) + (mapc #'add-lambda-vars-and-let-vars-to-closures + (component-lambdas component)) + + (find-non-local-exits component) + (recheck-dynamic-extent-lvars component) + (find-cleanup-points component) + (tail-annotate component) + (analyze-indirect-lambda-vars component) + + (dolist (fun (component-lambdas component)) + (when (null (leaf-refs fun)) + (let ((kind (functional-kind fun))) + (unless (or (eq kind :toplevel) + (functional-has-external-references-p fun)) + (aver (member kind '(:optional :cleanup :escape))) + (setf (functional-kind fun) nil) + (delete-functional fun))))) + + (setf (component-nlx-info-generated-p component) t) + (values)) + +;;; If FUN has an environment, return it, otherwise assign an empty +;;; one and return that. +(defun get-lambda-environment (fun) + (declare (type clambda fun)) + (let ((fun (lambda-home fun))) + (or (lambda-environment fun) + (let ((res (make-environment :lambda fun))) + (setf (lambda-environment fun) res) + (dolist (lambda (lambda-lets fun)) + (setf (lambda-environment lambda) res)) + res)))) + +;;; Get NODE's environment, assigning one if necessary. +(defun get-node-environment (node) + (declare (type node node)) + (get-lambda-environment (node-home-lambda node))) + +;;; private guts of ADD-LAMBDA-VARS-AND-LET-VARS-TO-CLOSURES +;;; +;;; This is the old CMU CL COMPUTE-CLOSURE, which only works on +;;; LAMBDA-VARS directly, not on the LAMBDA-VARS of LAMBDA-LETS. It +;;; seems never to be valid to use this operation alone, so in SBCL, +;;; it's private, and the public interface, +;;; ADD-LAMBDA-VARS-AND-LET-VARS-TO-CLOSURES, always runs over all the +;;; variables, not only the LAMBDA-VARS of CLAMBDA itself but also +;;; the LAMBDA-VARS of CLAMBDA's LAMBDA-LETS. +(defun %add-lambda-vars-to-closures (clambda) + (let ((env (get-lambda-environment clambda)) + (did-something nil)) + (note-unreferenced-fun-vars clambda) + (dolist (var (lambda-vars clambda)) + (dolist (ref (leaf-refs var)) + (let ((ref-env (get-node-environment ref))) + (unless (eq ref-env env) + (when (lambda-var-sets var) + (setf (lambda-var-indirect var) t)) + (setq did-something t) + (close-over var ref-env env)))) + (dolist (set (basic-var-sets var)) + + ;; Variables which are set but never referenced can be + ;; optimized away, and closing over them here would just + ;; interfere with that. (In bug 147, it *did* interfere with + ;; that, causing confusion later. This UNLESS solves that + ;; problem, but I (WHN) am not 100% sure it's best to solve + ;; the problem this way instead of somehow solving it + ;; somewhere upstream and just doing (AVER (LEAF-REFS VAR)) + ;; here.) + (unless (null (leaf-refs var)) + + (let ((set-env (get-node-environment set))) + (unless (eq set-env env) + (setf did-something t + (lambda-var-indirect var) t) + (close-over var set-env env)))))) + did-something)) + +;;; Find any variables in CLAMBDA -- either directly in LAMBDA-VARS or +;;; in the LAMBDA-VARS of elements of LAMBDA-LETS -- with references +;;; outside of the home environment and close over them. If a +;;; closed-over variable is set, then we set the INDIRECT flag so that +;;; we will know the closed over value is really a pointer to the +;;; value cell. We also warn about unreferenced variables here, just +;;; because it's a convenient place to do it. We return true if we +;;; close over anything. +(defun add-lambda-vars-and-let-vars-to-closures (clambda) + (declare (type clambda clambda)) + (let ((did-something nil)) + (when (%add-lambda-vars-to-closures clambda) + (setf did-something t)) + (dolist (lambda-let (lambda-lets clambda)) + ;; There's no need to recurse through full COMPUTE-CLOSURE + ;; here, since LETS only go one layer deep. + (aver (null (lambda-lets lambda-let))) + (when (%add-lambda-vars-to-closures lambda-let) + (setf did-something t))) + did-something)) + +(defun xep-enclose (xep) + (let ((entry (functional-entry-fun xep))) + (functional-enclose entry))) + +;;; Make sure that THING is closed over in REF-ENV and in all +;;; environments for the functions that reference REF-ENV's function +;;; (not just calls). HOME-ENV is THING's home environment. When we +;;; reach the home environment, we stop propagating the closure. +(defun close-over (thing ref-env home-env) + (declare (type environment ref-env home-env)) + (let ((flooded-envs nil)) + (labels ((flood (flooded-env) + (unless (or (eql flooded-env home-env) + (member flooded-env flooded-envs)) + (push flooded-env flooded-envs) + (unless (memq thing (environment-closure flooded-env)) + (push thing (environment-closure flooded-env)) + (let ((lambda (environment-lambda flooded-env))) + (cond ((eq (functional-kind lambda) :external) + (let ((enclose-env (get-node-environment (xep-enclose lambda)))) + (flood enclose-env) + (dolist (ref (leaf-refs lambda)) + (close-over lambda + (get-node-environment ref) enclose-env)))) + (t (dolist (ref (leaf-refs lambda)) + ;; FIXME: This assertion looks + ;; reasonable, but does not work for + ;; :CLEANUPs. + #+nil + (let ((dest (node-dest ref))) + (aver (basic-combination-p dest)) + (aver (eq (basic-combination-kind dest) :local))) + (flood (get-node-environment ref)))))))))) + (flood ref-env))) + (values)) + +;;; Find LAMBDA-VARs that are marked as needing to support indirect +;;; access (SET at some point after initial creation) that are present +;;; in CLAMBDAs not marked as being DYNAMIC-EXTENT (meaning that the +;;; value-cell involved must be able to survive past the extent of the +;;; allocating frame), and mark them (the LAMBDA-VARs) as needing +;;; explicit value-cells. Because they are already closed-over, the +;;; LAMBDA-VARs already appear in the closures of all of the CLAMBDAs +;;; that need checking. +(defun analyze-indirect-lambda-vars (component) + (dolist (fun (component-lambdas component)) + (let ((entry-fun (functional-entry-fun fun))) + ;; We also check the ENTRY-FUN, as XEPs for LABELS or FLET + ;; functions aren't set to be DX even if their underlying + ;; CLAMBDAs are, and if we ever get LET-bound anonymous function + ;; DX working, it would mark the XEP as being DX but not the + ;; "real" CLAMBDA. This works because a FUNCTIONAL-ENTRY-FUN is + ;; either NULL, a self-pointer (for :TOPLEVEL functions), a + ;; pointer from an XEP to its underlying function (for :EXTERNAL + ;; functions), or a pointer from an underlying function to its + ;; XEP (for non-:TOPLEVEL functions with XEPs). + (unless (or (leaf-dynamic-extent fun) + ;; Functions without XEPs can be treated as if they + ;; are DYNAMIC-EXTENT, even without being so + ;; declared, as any escaping closure which /isn't/ + ;; DYNAMIC-EXTENT but calls one of these functions + ;; will also close over the required variables, thus + ;; forcing the allocation of value cells. Since the + ;; XEP is stored in the ENTRY-FUN slot, we can pick + ;; off the non-XEP case here. + (not entry-fun) + (leaf-dynamic-extent entry-fun)) + (let ((closure (environment-closure (lambda-environment fun)))) + (dolist (var closure) + (when (and (lambda-var-p var) + (lambda-var-indirect var)) + (setf (lambda-var-explicit-value-cell var) t)))))))) + +;;;; non-local exit + +(defvar *functional-escape-info*) + +(defun functional-may-escape-p (functional) + (binding* ((functional (if (lambda-p functional) + (lambda-home functional) + functional)) + (table (or *functional-escape-info* + ;; Many components have no escapes, so we + ;; allocate it lazily. + (setf *functional-escape-info* + (make-hash-table :test #'eq)))) + ((bool ok) (gethash functional table))) + (if ok + bool + (let ((entry (functional-entry-fun functional))) + ;; First stick a NIL in there: break cycles. + (setf (gethash functional table) nil) + ;; Then compute the real value. + (setf (gethash functional table) + (and + ;; ESCAPE functionals would never escape from their target + (neq (functional-kind functional) :escape) + (or + ;; If the functional has a XEP, it's kind is :EXTERNAL -- + ;; which means it may escape. ...but if it + ;; HAS-EXTERNAL-REFERENCES-P, then that XEP is actually a + ;; TL-XEP, which means it's a toplevel function -- which in + ;; turn means our search has bottomed out without an escape + ;; path. AVER just to make sure, though. + (and (eq :external (functional-kind functional)) + (if (functional-has-external-references-p functional) + (aver (eq 'tl-xep (car (functional-debug-name functional)))) + t)) + ;; If it has an entry point that may escape, that just as bad. + (and entry (functional-may-escape-p entry)) + ;; If it has references to it in functions that may escape, that's bad + ;; too. + (dolist (ref (functional-refs functional) nil) + (binding* ((lvar (ref-lvar ref) :exit-if-null) + (dest (lvar-dest lvar) :exit-if-null)) + (when (functional-may-escape-p (node-home-lambda dest)) + (return t))))))))))) + +(defun exit-should-check-tag-p (exit) + (declare (type exit exit)) + (let ((exit-lambda (lexenv-lambda (node-lexenv exit)))) + (unless (or + ;; Unsafe but fast... + (policy exit (zerop check-tag-existence)) + ;; Dynamic extent is a promise things won't escape -- + ;; and an explicit request to avoid heap consing. + (member (lambda-extent exit-lambda) '(truly-dynamic-extent dynamic-extent)) + ;; If the exit lambda cannot escape, then we should be safe. + ;; ...since the escape analysis is kinda new, and not particularly + ;; exhaustively tested, let alone proven, disable it for SAFETY 3. + (and (policy exit (< safety 3)) + (not (functional-may-escape-p exit-lambda)))) + (when (policy exit (> speed safety)) + (let ((*compiler-error-context* (exit-entry exit))) + (compiler-notify "~@" + (node-source-form exit)))) + t))) + +;;; Insert the entry stub before the original exit target, and add a +;;; new entry to the ENVIRONMENT-NLX-INFO. The %NLX-ENTRY call in the +;;; stub is passed the NLX-INFO as an argument so that the back end +;;; knows what entry is being done. +;;; +;;; The link from the EXIT block to the entry stub is changed to be a +;;; link from the component head. Similarly, the EXIT block is linked +;;; to the component tail. This leaves the entry stub reachable, but +;;; makes the flow graph less confusing to flow analysis. +;;; +;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the +;;; last node in the cleanup code to be the enclosing environment, to +;;; represent the fact that the binding was undone as a side effect of +;;; the exit. This will cause a lexical exit to be broken up if we are +;;; actually exiting the scope (i.e. a BLOCK), and will also do any +;;; other cleanups that may have to be done on the way. +(defun insert-nlx-entry-stub (exit env) + (declare (type environment env) (type exit exit)) + (let* ((exit-block (node-block exit)) + (next-block (first (block-succ exit-block))) + (entry (exit-entry exit)) + (cleanup (entry-cleanup entry)) + (info (make-nlx-info cleanup (first (block-succ exit-block)))) + (new-block (insert-cleanup-code (list exit-block) next-block + entry + `(%nlx-entry ,(opaquely-quote info)) + cleanup)) + (component (block-component new-block))) + (unlink-blocks exit-block new-block) + (link-blocks exit-block (component-tail component)) + (link-blocks (component-head component) new-block) + + (setf (exit-nlx-info exit) info) + (setf (nlx-info-target info) new-block) + (setf (nlx-info-safe-p info) (exit-should-check-tag-p exit)) + (push info (environment-nlx-info env)) + (push info (cleanup-info cleanup)) + (when (member (cleanup-kind cleanup) '(:catch :unwind-protect)) + (setf (node-lexenv (block-last new-block)) + (node-lexenv entry)))) + + (values)) + +;;; Do stuff necessary to represent a non-local exit from the node +;;; EXIT into ENV. This is called for each non-local exit node, of +;;; which there may be several per exit continuation. This is what we +;;; do: +;;; -- If there isn't any NLX-INFO entry in the environment, make +;;; an entry stub, otherwise just move the exit block link to +;;; the component tail. +;;; -- Close over the NLX-INFO in the exit environment. +;;; -- If the exit is from an :ESCAPE function, then substitute a +;;; constant reference to NLX-INFO structure for the escape +;;; function reference. This will cause the escape function to +;;; be deleted (although not removed from the DFO.) The escape +;;; function is no longer needed, and we don't want to emit code +;;; for it. +;;; -- Change the %NLX-ENTRY call to use the NLX lvar so that 1) there +;;; will be a use to represent the NLX use; 2) make life easier for +;;; the stack analysis. +(defun note-non-local-exit (env exit) + (declare (type environment env) (type exit exit)) + (let ((lvar (node-lvar exit)) + (exit-fun (node-home-lambda exit)) + (info (find-nlx-info exit))) + (cond (info + (let ((block (node-block exit))) + (aver (= (length (block-succ block)) 1)) + (unlink-blocks block (first (block-succ block))) + (link-blocks block (component-tail (block-component block))) + (setf (exit-nlx-info exit) info) + (unless (nlx-info-safe-p info) + (setf (nlx-info-safe-p info) + (exit-should-check-tag-p exit))))) + (t + (insert-nlx-entry-stub exit env) + (setq info (exit-nlx-info exit)) + (aver info))) + (close-over info (node-environment exit) env) + (when (eq (functional-kind exit-fun) :escape) + (mapc (lambda (x) + (setf (node-derived-type x) *wild-type*)) + (leaf-refs exit-fun)) + (substitute-leaf (find-constant (opaquely-quote info)) exit-fun)) + (when lvar + (let ((node (block-last (nlx-info-target info)))) + (unless (node-lvar node) + (aver (eq lvar (node-lvar exit))) + (setf (node-derived-type node) (lvar-derived-type lvar)) + (add-lvar-use node lvar))))) + (values)) + +;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT +;;; when we find a block that ends in a non-local EXIT node. +(defun find-non-local-exits (component) + (declare (type component component)) + (let ((*functional-escape-info* nil)) + (dolist (lambda (component-lambdas component)) + (dolist (entry (lambda-entries lambda)) + (let ((target-env (node-environment entry))) + (dolist (exit (entry-exits entry)) + (aver (neq (node-environment exit) target-env)) + (note-non-local-exit target-env exit)))))) + (values)) + +;;;; final decision on stack allocation of dynamic-extent structures +(defun recheck-dynamic-extent-lvars (component) + (declare (type component component)) + (let (*dx-combination-p-check-local*) ;; catch unconverted combinations + (dolist (lambda (component-lambdas component)) + (dolist (entry (lambda-entries lambda)) + (let ((cleanup (entry-cleanup entry))) + (when (eq (cleanup-kind cleanup) :dynamic-extent) + (let ((real-dx-lvars '())) + (dolist (what (cleanup-info cleanup)) + (etypecase what + (cons + (let ((dx (car what)) + (lvar (cdr what))) + (cond ((lvar-good-for-dx-p lvar dx) + ;; Since the above check does deep + ;; checks. we need to deal with the deep + ;; results in here as well. + (dolist (cell (handle-nested-dynamic-extent-lvars + dx lvar)) + (let ((real (principal-lvar (cdr cell)))) + (setf (lvar-dynamic-extent real) cleanup) + (pushnew real real-dx-lvars)))) + (t + (note-no-stack-allocation lvar) + (setf (lvar-dynamic-extent lvar) nil))))) + (enclose ; DX closure + (let* ((funs (enclose-funs what)) + (dx nil)) + (dolist (fun funs) + (when (leaf-dynamic-extent fun) + (let ((xep (functional-entry-fun fun))) + (when xep + (cond ((environment-closure (get-lambda-environment xep)) + (setq dx t)) + (t + (setf (leaf-extent fun) nil))))))) + (when dx + (let ((lvar (make-lvar))) + (use-lvar what lvar) + (setf (lvar-dynamic-extent lvar) cleanup) + (push lvar real-dx-lvars))))))) + (setf (cleanup-info cleanup) real-dx-lvars) + (setf (component-dx-lvars component) + (append real-dx-lvars (component-dx-lvars component))))))))) + (values)) + +;;;; cleanup emission + +;;; Zoom up the cleanup nesting until we hit CLEANUP1, accumulating +;;; cleanup code as we go. When we are done, convert the cleanup code +;;; in an implicit MV-PROG1. We have to force local call analysis of +;;; new references to UNWIND-PROTECT cleanup functions. If we don't +;;; actually have to do anything, then we don't insert any cleanup +;;; code. (FIXME: There's some confusion here, left over from CMU CL +;;; comments. CLEANUP1 isn't mentioned in the code of this function. +;;; It is in code elsewhere, but if the comments for this function +;;; mention it they should explain the relationship to the other code.) +;;; +;;; If we do insert cleanup code, we check that BLOCK1 doesn't end in +;;; a "tail" local call. +;;; +;;; We don't need to adjust the ending cleanup of the cleanup block, +;;; since the cleanup blocks are inserted at the start of the DFO, and +;;; are thus never scanned. +(defun emit-cleanups (pred-blocks succ-block) + (collect ((code) + (reanalyze-funs)) + (let ((succ-cleanup (block-start-cleanup succ-block))) + (do-nested-cleanups (cleanup (block-end-lexenv (car pred-blocks))) + (when (eq cleanup succ-cleanup) + (return)) + (let* ((node (cleanup-mess-up cleanup)) + (args (when (basic-combination-p node) + (basic-combination-args node)))) + (ecase (cleanup-kind cleanup) + (:special-bind + (code `(%special-unbind ',(lvar-value (car args))))) + (:catch + (code `(%catch-breakup ,(opaquely-quote (car (cleanup-info cleanup)))))) + (:unwind-protect + (code `(%unwind-protect-breakup ,(opaquely-quote (car (cleanup-info cleanup))))) + (let ((fun (ref-leaf (lvar-uses (second args))))) + (when (functional-p fun) + (reanalyze-funs fun) + (code `(%funcall ,fun))))) + ((:block :tagbody) + (dolist (nlx (cleanup-info cleanup)) + (code `(%lexical-exit-breakup ,(opaquely-quote nlx))))) + (:dynamic-extent + (when (cleanup-info cleanup) + (code `(%cleanup-point)))) + (:restore-nsp + (code `(%primitive set-nsp ,(ref-leaf node)))))))) + (flet ((coalesce-unbinds (code) + (if (vop-existsp :named sb-c:unbind-n) + (loop with cleanup + while code + do (setf cleanup (pop code)) + collect (if (eq (car cleanup) '%special-unbind) + `(%special-unbind + ,(cadr cleanup) + ,@(loop while (eq (caar code) '%special-unbind) + collect (cadar code) + do (pop code))) + cleanup)) + code))) + (when (code) + (aver (not (node-tail-p (block-last (car pred-blocks))))) + (insert-cleanup-code + pred-blocks succ-block (block-last (car pred-blocks)) + `(progn ,@(coalesce-unbinds (code)))) + (dolist (fun (reanalyze-funs)) + (locall-analyze-fun-1 fun))))) + (values)) + +;;; Loop over the blocks in COMPONENT, calling EMIT-CLEANUPS when we +;;; see a successor in the same environment with a different cleanup. +;;; We ignore the cleanup transition if it is to a cleanup enclosed by +;;; the current cleanup, since in that case we are just messing up the +;;; environment, hence this is not the place to clean it. +(defun find-cleanup-points (component) + (declare (type component component)) + (do-blocks (block1 component) + (unless (block-to-be-deleted-p block1) + (let ((env1 (block-environment block1)) + (cleanup1 (block-end-cleanup block1))) + (dolist (block2 (block-succ block1)) + (when (block-start block2) + (let ((env2 (block-environment block2)) + (cleanup2 (block-start-cleanup block2))) + (unless (or (not (eq env2 env1)) + (eq cleanup1 cleanup2) + (and cleanup2 + (eq (node-enclosing-cleanup + (cleanup-mess-up cleanup2)) + cleanup1))) + ;; If multiple blocks with the same cleanups end up at the same block + ;; issue only one cleanup, e.g. (let (*) (if x 1 2)) + ;; + ;; Possible improvement: (let (*) (if x (let (**) 1) 2)) + ;; unbinding * only once. + (emit-cleanups (loop for pred in (block-pred block2) + when (or (eq pred block1) + (and + (block-start pred) + (eq (block-end-cleanup pred) cleanup1) + (eq (block-environment pred) env2))) + collect pred) + block2)))))))) + (values)) + +;;; Mark optimizable tail-recursive uses of function result +;;; continuations with the corresponding TAIL-SET. +;;; +;;; Regarding the suppression of TAIL-P for nil-returning calls, +;;; a partial history of the changes affecting this is as follows: +;;; +;;; WHN said [in 85f9c92558538b85540ff420fa8970af91e241a2] +;;; ;; Nodes whose type is NIL (i.e. don't return) such as calls to +;;; ;; ERROR are never annotated as TAIL-P, in order to preserve +;;; ;; debugging information. +;;; +;;; NS added [in bea5b384106a6734a4b280a76e8ebdd4d51b5323] +;;; ;; Why is that bad? Because this non-elimination of +;;; ;; non-returning tail calls causes the XEP for FOO [to] appear in +;;; ;; backtrace for (defun foo (x) (error "foo ~S" x)) w[h]ich seems +;;; ;; less then optimal. --NS 2005-02-28 +;;; (not considering that the point of non-elimination was specifically +;;; to allow FOO to appear in the backtrace?) +;;; +(defun tail-annotate (component) + (declare (type component component)) + (dolist (fun (component-lambdas component)) + (let ((ret (lambda-return fun))) + ;; The code below assumes that a lambda whose final node is a call to + ;; a non-returning function gets a lambda-return. But it doesn't always, + ;; and it's not clear whether that means "always doesn't". + ;; If it never does, then (WHEN RET ..) will never execute, so we won't + ;; even see the call that might be be annotated as tail-p, regardless + ;; of whether we *want* to annotate it as such. + (when ret + (let ((result (return-result ret))) + (do-uses (use result) + (when (and (basic-combination-p use) + (immediately-used-p result use) + (or (eq (basic-combination-kind use) :local) + ;; Nodes whose type is NIL (i.e. don't return) such + ;; as calls to ERROR are never annotated as TAIL-P, + ;; in order to preserve debugging information, so that + ;; + ;; We spread this net wide enough to catch + ;; untrusted NIL return types as well, so that + ;; frames calling functions such as FOO-ERROR are + ;; kept in backtraces: + ;; + ;; (defun foo-error (x) (error "oops: ~S" x)) + ;; + (not (or (eq *empty-type* (node-derived-type use)) + (eq *empty-type* (combination-defined-type use)))))) + (setf (node-tail-p use) t))))))) + ;; The above loop does not find all calls to ERROR. + (do-blocks (block component) + (do-nodes (node nil block) + ;; CAUTION: This looks scary because it affects all known nil-returning + ;; calls even if not in tail position. Use of the policy quality which + ;; enables tail-p must be confined to a very restricted lexical scope. + ;; This might be better implemented as a local declaration about + ;; function names at the call site: (declare (uninhibit-tco error)) + ;; but adding new kinds of declarations is fairly invasive surgery. + (when (and (combination-p node) + (combination-fun-info node) ; must be a known fun + (eq (combination-defined-type node) *empty-type*) + (policy node (= allow-non-returning-tail-call 3))) + (setf (node-tail-p node) t)))) + (values)) diff -Nru sbcl-2.1.1/src/compiler/equality-constraints.lisp sbcl-2.1.11/src/compiler/equality-constraints.lisp --- sbcl-2.1.1/src/compiler/equality-constraints.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/equality-constraints.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -207,25 +207,32 @@ (defoptimizer (- equality-constraint) ((x y) node) (let ((integer (specifier-type 'integer))) - (when (and (types-equal-or-intersect (lvar-type x) integer) - (types-equal-or-intersect (lvar-type y) integer)) + (when (and (csubtypep (lvar-type x) integer) + (csubtypep (lvar-type y) integer)) (macrolet ((f (op x y pos) `(let ((constr (find-ref-equality-constraint ',op ,x ,y nil))) (when constr (if (constraint-not-p constr) ,@(if pos - `((go POS) (go NEG)) - `((go NEG) (go POS)))))))) + `((go GTEZ) (go LTZ)) + `((go LTEZ) (go GTZ))))))) + (derive (type) + `(progn + (derive-node-type node (specifier-type ',type)) + (go DONE)))) (tagbody (f < x y t) (f > x y nil) (f > y x t) (f < y x nil) (go DONE) - POS - (derive-node-type node (specifier-type '(integer 0))) - (go DONE) - NEG - (derive-node-type node (specifier-type '(integer * (0)))) + GTZ + (derive (integer (0))) + LTZ + (derive (integer * (0))) + GTEZ + (derive (integer 0)) + LTEZ + (derive (integer * 0)) DONE)))) :give-up) diff -Nru sbcl-2.1.1/src/compiler/fixup-type.lisp sbcl-2.1.11/src/compiler/fixup-type.lisp --- sbcl-2.1.1/src/compiler/fixup-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/fixup-type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -26,6 +26,16 @@ (dovector (pair *!initial-parsed-types*) (destructuring-bind (spec . parse) pair (drop-all-hash-caches) ; start from a relative vacuum - (aver (equal (type-specifier parse) spec))))) + (unless (sb-kernel::brute-force-type-specifier-equalp (type-specifier parse) spec) + (let ((*print-length* nil)) + (write-string "parse/unparse: ") + (terpri) + (write spec) + (terpri) + (write parse) + (terpri) + (write (type-specifier parse)) + (terpri) + (bug "type parsed->unparse round-trip fail")))))) (!defun-from-collected-cold-init-forms !fixup-type-cold-init) diff -Nru sbcl-2.1.1/src/compiler/float-tran.lisp sbcl-2.1.11/src/compiler/float-tran.lisp --- sbcl-2.1.1/src/compiler/float-tran.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/float-tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -15,10 +15,10 @@ ;;;; coercions -(deftransform float ((n f) (* single-float) *) +(deftransform float ((n f) (t single-float) *) '(%single-float n)) -(deftransform float ((n f) (* double-float) *) +(deftransform float ((n f) (t double-float) *) '(%double-float n)) (deftransform float ((n) *) @@ -35,7 +35,7 @@ ;;; RANDOM (macrolet ((frob (fun type) `(deftransform random ((num &optional state) - (,type &optional *) *) + (,type &optional t) *) "Use inline float operations." '(,fun num (or state *random-state*))))) (frob %random-single-float single-float) @@ -67,7 +67,7 @@ ;;; a division to get the random value into the desired range. (deftransform random ((num &optional state) ((constant-arg (integer 1 #.(expt 2 sb-vm:n-word-bits))) - &optional *) + &optional t) * :policy (and (> speed compilation-speed) (> speed space))) @@ -220,7 +220,7 @@ (deftransform integer-decode-float ((x) (double-float) *) '(integer-decode-double-float x)) -(deftransform scale-float ((f ex) (single-float *) *) +(deftransform scale-float ((f ex) (single-float t) *) (cond #+x86 ((csubtypep (lvar-type ex) (specifier-type '(signed-byte 32))) @@ -228,7 +228,7 @@ (t '(scale-single-float f ex)))) -(deftransform scale-float ((f ex) (double-float *) *) +(deftransform scale-float ((f ex) (double-float t) *) (cond #+x86 ((csubtypep (lvar-type ex) (specifier-type '(signed-byte 32))) @@ -338,18 +338,20 @@ ;;; Do some stuff to recognize when the loser is doing mixed float and ;;; rational arithmetic, or different float types, and fix it up. If -;;; we don't, he won't even get so much as an efficiency note. +;;; we don't, we won't even get so much as an efficiency note. ;;; Unfortunately this produces unnecessarily bad code for something ;;; as simple as (ZEROP (THE FLOAT X)) because we _know_ that the thing ;;; is a float, but the ZEROP transform injected a rational 0, ;;; which we then go to the trouble of coercing to a float. (progn (deftransform real-float-contagion-arg1 ((x y) * * :defun-only t :node node) + "open-code float conversion in mixed numeric operation" (if (or (not (types-equal-or-intersect (lvar-type y) (specifier-type 'single-float))) (safe-ctype-for-single-coercion-p (lvar-type x))) `(,(lvar-fun-name (basic-combination-fun node)) (float x y) y) (give-up-ir1-transform #1="the first argument cannot safely be converted to SINGLE-FLOAT"))) (deftransform complex-float-contagion-arg1 ((x y) * * :defun-only t :node node) + "open-code float conversion in mixed numeric operation" (if (or (not (types-equal-or-intersect (lvar-type y) (specifier-type '(complex single-float)))) (safe-ctype-for-single-coercion-p (lvar-type x))) @@ -357,11 +359,13 @@ (float x (realpart y)) y) (give-up-ir1-transform #1#))) (deftransform real-float-contagion-arg2 ((x y) * * :defun-only t :node node) + "open-code float conversion in mixed numeric operation" (if (or (not (types-equal-or-intersect (lvar-type x) (specifier-type 'single-float))) (safe-ctype-for-single-coercion-p (lvar-type y))) `(,(lvar-fun-name (basic-combination-fun node)) x (float y x)) (give-up-ir1-transform #2="the second argument cannot safely be converted to SINGLE-FLOAT"))) (deftransform complex-float-contagion-arg2 ((x y) * * :defun-only t :node node) + "open-code float conversion in mixed numeric operation" (if (or (not (types-equal-or-intersect (lvar-type x) (specifier-type '(complex single-float)))) (safe-ctype-for-single-coercion-p (lvar-type y))) `(,(lvar-fun-name (basic-combination-fun node)) @@ -377,11 +381,7 @@ (2 (if complexp (values `(complex ,float-type) other-type #'complex-float-contagion-arg2) (values float-type other-type #'real-float-contagion-arg2)))) - (let ((note (format nil "open-code float conversion of ~:R ~ - argument in mixed ~S-~S numeric ~ - operation" - argument type1 type2))) - (%deftransform operator `(function (,type1 ,type2) *) function note :slightly))))) + (%deftransform operator nil `(function (,type1 ,type2) *) function)))) (dolist (operator '(+ * / -)) (def operator 'float 'rational nil 1) @@ -479,10 +479,17 @@ (give-up-ir1-transform "The RATIONAL value isn't known at compile time.")) (let ((val (lvar-value y))) - (unless (eql (rational (float val)) val) - (give-up-ir1-transform - "~S doesn't have a precise float representation." - val))) + (multiple-value-bind (low high type) + (if (csubtypep (lvar-type x) (specifier-type 'double-float)) + (values most-negative-double-float most-positive-double-float + 'double-float) + (values most-negative-single-float most-positive-single-float + 'single-float)) + (unless (and (sb-xc:<= low val high) + (eql (rational (coerce val type)) val)) + (give-up-ir1-transform + "~S doesn't have a precise float representation." + val)))) `(,',op x (float y ,',(if complex '(realpart x) 'x)))))) @@ -619,15 +626,21 @@ ;;; should be the right kind of float. Allow bounds for the float ;;; part too. (defun float-or-complex-float-type (arg &optional lo hi) - (declare (type numeric-type arg)) - (let* ((format (case (numeric-type-class arg) - ((integer rational) 'single-float) - (t (numeric-type-format arg)))) - (float-type (or format 'float)) - (lo (coerce-numeric-bound lo float-type)) - (hi (coerce-numeric-bound hi float-type))) - (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*)) - (complex ,float-type))))) + (cond + ((numeric-type-p arg) + (let* ((format (case (numeric-type-class arg) + ((integer rational) 'single-float) + (t (numeric-type-format arg)))) + (float-type (or format 'float)) + (lo (coerce-numeric-bound lo float-type)) + (hi (coerce-numeric-bound hi float-type))) + (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*)) + (complex ,float-type))))) + ((union-type-p arg) + (apply #'type-union + (loop for type in (union-type-types arg) + collect (float-or-complex-float-type type lo hi)))) + (t (specifier-type 'number)))) (eval-when (:compile-toplevel :execute) ;; So the problem with this hack is that it's actually broken. If @@ -831,7 +844,7 @@ (list (interval-expt-> x y-) (interval-expt-> x y+)))))) -;;; Handle the case when x <= 1 +;;; Handle the case when 0 <= x <= 1 (defun interval-expt-< (x y) (case (interval-range-info x $0d0) (+ @@ -862,9 +875,13 @@ (interval-expt-< x y+)))))) (- ;; The case where x <= 0. Y MUST be an INTEGER for this to work! - ;; The calling function must insure this! For now we'll just - ;; return the appropriate unbounded float type. - (list (make-interval :low nil :high nil))) + ;; The calling function must insure this! + (loop for interval in (flatten-list (interval-expt (interval-neg x) y)) + for low = (interval-low interval) + for high = (interval-high interval) + collect interval + when (or high low) + collect (interval-neg interval))) (t (destructuring-bind (neg pos) (interval-split 0 x t t) @@ -1516,7 +1533,7 @@ (macrolet ((define-frobs (fun ufun) `(deftransform ,fun ((x &optional by) - (* &optional (constant-arg (member 1)))) + (t &optional (constant-arg (member 1)))) '(let ((res (,ufun x))) (values res (locally (declare (flushable %single-float @@ -1550,7 +1567,8 @@ * :result result) (let* ((result-type (and result (lvar-derived-type result))) - (compute-all (and (values-type-p result-type) + (compute-all (and (or (eq result-type *wild-type*) + (values-type-p result-type)) (not (type-single-value-p result-type))))) (if (or (not y) (and (constant-lvar-p y) (= 1 (lvar-value y)))) diff -Nru sbcl-2.1.1/src/compiler/fndb.lisp sbcl-2.1.11/src/compiler/fndb.lisp --- sbcl-2.1.1/src/compiler/fndb.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/fndb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -98,10 +98,10 @@ (defknown find-classoid (name-for-class &optional t) (or classoid null) ()) (defknown classoid-of (t) classoid (flushable)) -(defknown layout-of (t) layout (flushable)) -#+64-bit (defknown layout-depthoid (layout) layout-depthoid (flushable always-translatable)) -#+(or x86 x86-64) (defknown (layout-depthoid-ge) - (layout integer) boolean (flushable)) +(defknown wrapper-of (t) wrapper (flushable)) +(defknown wrapper-depthoid (wrapper) layout-depthoid (flushable)) +#+64-bit (defknown layout-depthoid (sb-vm:layout) layout-depthoid (flushable always-translatable)) +#+(or x86 x86-64) (defknown (layout-depthoid-ge) (sb-vm:layout integer) boolean (flushable)) (defknown %structure-is-a (instance t) boolean (foldable flushable)) (defknown copy-structure (structure-object) structure-object (flushable) @@ -124,7 +124,7 @@ (defknown (symbol-function) (symbol) function ()) (defknown boundp (symbol) boolean (flushable)) -(defknown fboundp ((or symbol cons)) boolean (unsafely-flushable)) +(defknown fboundp ((or symbol cons)) (or null function) (unsafely-flushable)) (defknown special-operator-p (symbol) t ;; The set of special operators never changes. (movable foldable flushable)) @@ -343,6 +343,9 @@ (defknown %multiply-high (word word) word (movable foldable flushable)) +(defknown multiply-fixnums (fixnum fixnum) integer + (movable foldable flushable)) + (defknown %signed-multiply-high (sb-vm:signed-word sb-vm:signed-word) sb-vm:signed-word (movable foldable flushable)) @@ -367,7 +370,18 @@ ;;; e.g. the behavior if the first arg is a NaN is well-defined as we have it, ;;; but what about the second arg? We need some test cases around this. (defknown float-sign (float &optional float) float - (movable foldable unsafely-flushable)) + (movable foldable unsafely-flushable) + :derive-type (lambda (call &aux (args (combination-args call)) + (type (unless (cdr args) (lvar-type (first args))))) + (cond ((and type (csubtypep type (specifier-type 'single-float))) + (specifier-type '(member $1f0 $-1f0))) + ((and type (csubtypep type (specifier-type 'double-float))) + (specifier-type '(member $1d0 $-1d0))) + (type + (specifier-type '(member $1f0 $-1f0 $1d0 $-1d0))) + (t + (specifier-type 'float))))) + (defknown (float-digits float-precision) (float) float-digits (movable foldable unsafely-flushable)) (defknown integer-decode-float (float) @@ -582,6 +596,19 @@ () :derive-type #'result-type-first-arg :result-arg 0) +;;; Like FILL but with no keyword argument parsing +(defknown quickfill ((modifying (simple-array * 1)) t) (simple-array * 1) () + :derive-type #'result-type-first-arg + :result-arg 0) +;;; Special case of FILL that takes either a machine word with which to fill, +;;; or a keyword indicating a certain behavior to compute the word. +;;; In either case the supplied count is lispwords, not elements. +;;; This might be a no-op depending on whether memory is prezeroized. +(defknown sb-vm::splat ((modifying (simple-array * 1)) index (or symbol sb-vm:word)) + (simple-array * 1) + (always-translatable) + :derive-type #'result-type-first-arg + :result-arg 0) (defknown replace ((modifying sequence) proper-sequence &rest t &key (:start1 index) (:end1 sequence-end) (:start2 index) (:end2 sequence-end)) @@ -880,17 +907,15 @@ (defknown list* (t &rest t) t (movable flushable)) ;;; The length constraint on MAKE-LIST is such that: ;;; - not every byte of addressable memory can be used up. -;;; - the number of bytes to allocate should not be a bignum, -;; nor can its native representation be larger than 'sword_t' -;;; So it's half of most-positive-word divided by the cons size, -;;; which is roughly twice as small as array-dimension-limit on 32-bit machines, -;;; or 8x smaller on 64-bit machines. +;;; - the number of bytes to allocate should be a fixnum +;;; - type-checking can use use efficient bit-masking approach +;;; to combine the fixnum + range test into one instruction (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant make-list-limit - (floor (/ sb-ext:most-positive-word 2) (* 2 sb-vm:n-word-bytes)))) -(defknown make-list ((integer 0 (#.make-list-limit)) &key (:initial-element t)) list + (ash most-positive-fixnum (- (+ sb-vm:word-shift 1))))) +(defknown make-list ((integer 0 #.make-list-limit) &key (:initial-element t)) list (movable flushable)) -(defknown %make-list ((integer 0 (#.make-list-limit)) t) list (movable flushable)) +(defknown %make-list ((integer 0 #.make-list-limit) t) list (movable flushable)) (defknown sb-impl::|List| (&rest t) list (movable flushable)) (defknown sb-impl::|List*| (t &rest t) t (movable flushable)) @@ -1037,6 +1062,7 @@ (:synchronized t)) hash-table (flushable)) +(defknown sb-impl::make-hash-table-using-defaults (integer) hash-table (flushable)) (defknown hash-table-p (t) boolean (movable foldable flushable)) (defknown gethash (t hash-table &optional t) (values t boolean) (flushable)) ; not FOLDABLE, since hash table contents can change @@ -1159,7 +1185,10 @@ (movable foldable flushable)) (defknown fill-pointer (complex-vector) index (unsafely-flushable)) -(defknown sb-impl::fill-pointer-error (t &optional t) nil) +;;; We could cut 1 instruction off the call sequence by not loading the arg count +;;; register for error-handler helpers that take fixed args. +;;; Perhaps they should all be trap instead though? +(defknown sb-vm::fill-pointer-error (t) nil) (defknown vector-push (t (modifying complex-vector)) (or index null) ()) (defknown vector-push-extend (t (modifying complex-vector) &optional (and index (integer 1))) index @@ -1167,15 +1196,15 @@ (defknown vector-pop ((modifying complex-vector)) t ()) ;;; FIXME: complicated MODIFYING -;;; Also, an important-result warning could be provided if the array -;;; is known to be not expressly adjustable. (defknown adjust-array (array (or index list) &key (:element-type type-specifier) (:initial-element t) (:initial-contents t) (:fill-pointer (or index boolean)) (:displaced-to (or array null)) (:displaced-index-offset index)) - array ()) + ;; This is a special case in CHECK-IMPORTANT-RESULT because it is not + ;; necessary to use the result if the array is adjustable. + array (important-result)) ; :derive-type 'result-type-arg1) Not even close... ;;;; from the "Strings" chapter: @@ -1651,21 +1680,29 @@ &key ;; ANSI options - (:output-file (or pathname-designator - null - ;; FIXME: This last case is a non-ANSI hack. - (member t))) + (:output-file pathname-designator) (:verbose t) (:print t) (:external-format external-format-designator) - (:progress t) ;; extensions + (:progress t) (:trace-file t) (:block-compile t) (:entry-points list) (:emit-cfasl t)) (values (or pathname null) boolean boolean)) +(defknown sb-c::compile-files + (cons &key (:output-file pathname-designator) + (:verbose t) + (:print t) + (:external-format external-format-designator) + (:progress t) + (:trace-file t) + (:block-compile t) + (:entry-points list) + (:emit-cfasl t)) + (values (or pathname null) boolean boolean)) (defknown (compile-file-pathname) (pathname-designator &key (:output-file (or pathname-designator @@ -1768,7 +1805,7 @@ ;;; We can't fold this in general because of SATISFIES. There is a ;;; special optimizer anyway. (defknown %typep (t (or type-specifier ctype)) boolean (movable flushable)) -(defknown %instance-typep (t (or type-specifier ctype layout)) boolean +(defknown %instance-typep (t (or type-specifier ctype wrapper)) boolean (movable flushable always-translatable)) ;;; We should never emit a call to %typep-wrapper (defknown %typep-wrapper (t t (or type-specifier ctype)) t @@ -1786,7 +1823,8 @@ (defknown %special-unbind (&rest symbol) t) (defknown %listify-rest-args (t index) list (flushable)) (defknown %more-arg-context (t t) (values t index) (flushable)) -(defknown %more-arg (t index) t) +(defknown %more-arg (t index) t (flushable)) +(defknown %more-keyword-pair (t fixnum) (values t t) (flushable)) #+stack-grows-downward-not-upward ;;; FIXME: The second argument here should really be NEGATIVE-INDEX, but doing that ;;; breaks the build, and I cannot seem to figure out why. --NS 2006-06-29 @@ -1809,11 +1847,10 @@ (defknown %pop-values (t) t) (defknown %nip-values (t t &rest t) (values)) (defknown %dummy-dx-alloc (t t) t) -(defknown %allocate-closures (t) *) (defknown %type-check-error (t t t) nil) (defknown %type-check-error/c (t t t) nil) -;; FIXME: This function does not return, but due to the implementation +;; %compile-time-type-error does not return, but due to the implementation ;; of FILTER-LVAR we cannot write it here. (defknown (%compile-time-type-error %compile-time-type-style-warn) (t t t t t t) *) (defknown (etypecase-failure ecase-failure) (t t) nil) @@ -1828,14 +1865,15 @@ (defknown (%check-bound check-bound) (array index t) index (dx-safe)) (defknown data-vector-ref (simple-array index) t - (foldable unsafely-flushable always-translatable)) + (foldable flushable always-translatable)) (defknown data-vector-ref-with-offset (simple-array fixnum fixnum) t - (foldable unsafely-flushable always-translatable)) + (foldable flushable always-translatable)) (defknown data-nil-vector-ref (simple-array index) nil (always-translatable)) -(defknown data-vector-set (array index t) t - (always-translatable)) -(defknown data-vector-set-with-offset (array fixnum fixnum t) t +;;; The lowest-level vector SET operators should not return a value. +;;; Functions built upon them may return the input value. +(defknown data-vector-set (array index t) (values) (always-translatable)) +(defknown data-vector-set-with-offset (array fixnum fixnum t) (values) (always-translatable)) (defknown hairy-data-vector-ref (array index) t (foldable)) (defknown hairy-data-vector-set (array index t) t ()) @@ -1952,8 +1990,11 @@ (defknown %scharset ((modifying simple-string) index character) character ()) (defknown %set-symbol-value (symbol t) t ()) (defknown (setf symbol-function) (function symbol) function ()) -(defknown %set-symbol-plist (symbol list) list () - :derive-type #'result-type-last-arg) +;; Does this really need a type deriver? It's inline, and returns its 1st arg, +;; i.e. we know exactly what object it returns, which is more precise than +;; just knowing the type. +(defknown (setf symbol-plist) (list symbol) list () + :derive-type #'result-type-first-arg) (defknown %setnth (unsigned-byte (modifying list) t) t () :derive-type #'result-type-last-arg) (defknown %set-fill-pointer ((modifying complex-vector) index) index () @@ -1961,7 +2002,7 @@ ;;;; ALIEN and call-out-to-C stuff -(defknown %alien-funcall ((or string system-area-pointer) alien-type &rest *) *) +(defknown %alien-funcall ((or string system-area-pointer) alien-type &rest t) *) ;; Used by WITH-PINNED-OBJECTS #+(or x86 x86-64) @@ -2006,7 +2047,7 @@ ;;; Unfortunately it prints that noise at each call site. ;;; Using DEFKNOWN we can make the proclamation effective when ;;; running the cross-compiler but not when building it. -;;; Alternatively we could use SB-XC:PROCLAIM, except that that +;;; Alternatively we could use PROCLAIM, except that that ;;; doesn't exist soon enough, and would need conditionals guarding ;;; it, which is sort of the very thing this is trying to avoid. (defknown missing-arg () nil) @@ -2043,6 +2084,10 @@ (defknown sb-kernel::gc-safepoint () (values) ()) ;;;; atomic ops +;;; the CAS functions are transformed to something else rather than "translated". +;;; either way, they should not be called. +(defknown (cas svref) (t t simple-vector index) t (always-translatable)) +(defknown (cas symbol-value) (t t symbol) t (always-translatable)) (defknown %compare-and-swap-svref (simple-vector index t t) t ()) (defknown (%compare-and-swap-symbol-value @@ -2061,7 +2106,7 @@ ;;; Avoid a ton of FBOUNDP checks in the string stream constructors etc, ;;; by wiring in the needed functions instead of dereferencing their fdefns. (defknown (ill-in ill-bin ill-out ill-bout - sb-impl::string-inch sb-impl::string-in-misc + sb-impl::string-in-misc sb-impl::string-sout sb-impl::finite-base-string-ouch sb-impl::finite-base-string-out-misc sb-impl::fill-pointer-ouch sb-impl::fill-pointer-sout diff -Nru sbcl-2.1.1/src/compiler/fopcompile.lisp sbcl-2.1.11/src/compiler/fopcompile.lisp --- sbcl-2.1.1/src/compiler/fopcompile.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/fopcompile.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -62,10 +62,6 @@ ;; Special forms which we don't currently handle, but might consider ;; supporting in the future are LOCALLY (with declarations), ;; MACROLET, SYMBOL-MACROLET and THE. - ;; Also, if (FLET ((F () ...)) (DEFUN A () ...) (DEFUN B () ...)) - ;; were handled, then it would probably automatically work in - ;; the cold loader too, providing definitions for A and B before - ;; executing all other toplevel forms. (flet ((expand (form) (if expand (handler-case @@ -188,31 +184,10 @@ (let ((function (car form))) ;; Certain known functions have a special way of checking ;; their fopcompilability in the cross-compiler. - (or ;; allow %DEFUN, also ensuring that any inline lambda gets - ;; its constant structures (possibly containing COMMAs) noted - ;; as dumpable literals. - (and (eq function 'sb-impl::%defun) (fopcompilable-p (fourth form))) - (member function '(sb-pcl::!trivial-defmethod - sb-kernel::%defstruct - sb-thread:make-mutex)) - ;; allow DEF{CONSTANT,PARAMETER} only if the value form is ok - (and (member function '(%defconstant sb-impl::%defparameter)) - (fopcompilable-p (third form))) - (and (symbolp function) ; no ((lambda ...) ...) - (get-properties (symbol-plist function) - '(:sb-cold-funcall-handler/for-effect - :sb-cold-funcall-handler/for-value))) - (and (eq function 'setf) - (fopcompilable-p (%macroexpand form *lexenv*))) - (and (eq function 'sb-kernel:%svset) - (destructuring-bind (thing index value) (cdr form) - (and (symbolp thing) - (integerp index) - (eq (info :variable :kind thing) :global) - (typep value - '(cons (member lambda function named-lambda)))))) - (and (eq function 'setq) - (setq-fopcompilable-p (cdr form)))))))) + (or (member function '(sb-pcl::!trivial-defmethod)) + ;; allow DEFCONSTANT only if the value form is ok + (and (member function '(sb-impl::%defconstant)) + (fopcompilable-p (third form)))))))) ) ; end FLET (defun let-fopcompilable-p (operator args) @@ -256,14 +231,18 @@ ;;; it a leaf for dumping purposes. Symbols are leaflike despite havings slots ;;; containing pointers; similarly (COMPLEX RATIONAL) and RATIO. (defun dumpable-leaflike-p (obj) - (or (sb-xc:typep obj '(or symbol number character unboxed-array - debug-name-marker + (or (sb-xc:typep obj '(or symbol number character + ;; (ARRAY NIL) is not included in UNBOXED-ARRAY + (or unboxed-array (array nil)) system-area-pointer #+sb-simd-pack simd-pack #+sb-simd-pack-256 simd-pack-256)) + (cl:typep obj 'debug-name-marker) ;; STANDARD-OBJECT layouts use MAKE-LOAD-FORM, but all other layouts ;; have the same status as symbols - composite objects but leaflike. - (and (typep obj 'layout) (not (layout-for-pcl-obj-p obj))) + (and (typep obj 'wrapper) (not (layout-for-pcl-obj-p obj))) + ;; PACKAGEs are also leaflike. + (cl:typep obj 'package) ;; The cross-compiler wants to dump CTYPE instances as leaves, ;; but CLASSOIDs are excluded since they have a MAKE-LOAD-FORM method. #+sb-xc-host (cl:typep obj '(and ctype (not classoid))) @@ -370,7 +349,7 @@ ;; Lexical (let* ((var (cdr (assoc form (lexenv-vars *lexenv*)))) (handle (and (lambda-var-p var) - (lambda-var-fop-value var)))) + (leaf-info var)))) (cond (handle (setf (lambda-var-ever-used var) t) (when for-value-p @@ -460,7 +439,7 @@ (let* ((obj (sb-fasl::dump-pop fasl)) (var (make-lambda-var :%source-name name - :fop-value obj))) + :info obj))) (push var vars) (setf *lexenv* (make-lexenv @@ -473,7 +452,7 @@ (*compiler-error-context* (make-compiler-error-context :original-form form - :file-name (file-info-name file-info) + :file-name (file-info-truename file-info) :initialized t :file-position (nth-value 1 (find-source-root tlf *source-info*)) diff -Nru sbcl-2.1.1/src/compiler/generic/core.lisp sbcl-2.1.11/src/compiler/generic/core.lisp --- sbcl-2.1.1/src/compiler/generic/core.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/core.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -11,6 +11,13 @@ (in-package "SB-C") +;;; Unique number assigned into high 4 bytes of 64-bit code size slot +;;; so that we can sort the contents of varyobj space in a more-or-less +;;; predictable manner based on the order in which code was loaded. +;;; This wraps around at 32 bits, but it's still deterministic. +(define-load-time-global *code-serialno* 0) +(declaim (fixnum *code-serialno*)) + ;;; A CORE-OBJECT structure holds the state needed to resolve cross-component ;;; references during in-core compilation. (defstruct (core-object diff -Nru sbcl-2.1.1/src/compiler/generic/early-objdef.lisp sbcl-2.1.11/src/compiler/generic/early-objdef.lisp --- sbcl-2.1.1/src/compiler/generic/early-objdef.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/early-objdef.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -226,8 +226,8 @@ funcallable-instance-widetag ; 36 3D 36 3D ;; x86[-64] does not have objects with this widetag, - #-(or x86 x86-64) return-pc-widetag ; 3A 41 3A 41 - #+(or x86 x86-64) lra-widetag-notused + #-(or x86 x86-64 arm64) return-pc-widetag ; 3A 41 3A 41 + #+(or x86 x86-64 arm64) lra-widetag-notused value-cell-widetag ; 3E 45 3E 45 character-widetag ; 42 49 42 49 @@ -252,6 +252,9 @@ #-64-bit unused09-widetag ; 7E 7E simple-array-widetag ; 82 81 82 81 + ;; NIL element type is not in the contiguous range of widetags + ;; corresponding to SIMPLE-UNBOXED-ARRAY + simple-array-nil-widetag simple-vector-widetag ; simple-bit-vector-widetag ; simple-array-unsigned-byte-2-widetag ; @@ -285,9 +288,6 @@ simple-array-complex-single-float-widetag ; simple-array-complex-double-float-widetag ; - ;; Not a string type - simple-array-nil-widetag ; - simple-base-string-widetag ; D6 E1 D6 E1 \ #+sb-unicode ; | simple-character-string-widetag ; DA E5 | Strings @@ -310,12 +310,21 @@ ;;; Byte index: 3 2 1 0 ;;; +-----------------------------------+-----------+ -;;; | unused | rank | flags | widetag | +;;; | unused | rank <|> flags | widetag | ;;; +-----------+-----------+-----------+-----------+ ;;; |<---------- HEADER DATA ---------->| +;;; Having contiguous rank and widetag allows +;;; SIMPLE-ARRAY-HEADER-OF-RANK-P to be done with just one comparison. +;;; Other backends may not be ready to switch the order yet. +(defconstant array-rank-position #-arm64 16 #+arm64 8) +(defconstant array-flags-position #-arm64 8 #+arm64 16) + +(defconstant array-flags-data-position (- array-flags-position n-widetag-bits)) (defconstant +array-fill-pointer-p+ #x80) +(defconstant +vector-dynamic-extent+ #x40) + ;; A vector tagged as +VECTOR-SHAREABLE+ is logically readonly, ;; and permitted to be shared with another vector per the CLHS standard ;; under the concept of similarity as constant. A vector so tagged is diff -Nru sbcl-2.1.1/src/compiler/generic/early-type-vops.lisp sbcl-2.1.11/src/compiler/generic/early-type-vops.lisp --- sbcl-2.1.1/src/compiler/generic/early-type-vops.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/early-type-vops.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,174 +0,0 @@ -;;;; generic type testing and checking apparatus - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. -(in-package "SB-VM") - -(defconstant-eqx +immediate-types+ - `(,unbound-marker-widetag ,character-widetag #+64-bit ,single-float-widetag) - #'equal) - -;; Given a list of widetags in HEADERS, compress into a minimal list of ranges -;; and/or singletons that should be tested. -;; FIXME: At present the "is it effectively a one-sided test" is re-implemented -;; in an ad-hoc way by each backend. The range convention should be -;; changed to indicate explicitly when either limit needn't be checked. -;; (Use NIL or * as a bound perhaps) -(defun canonicalize-widetags (headers) - (collect ((results)) - (let ((start nil) - (prev nil) - (delta widetag-spacing)) - (flet ((emit-test () - (results (if (= start prev) - start - (cons start prev))))) - ;; COPY-LIST because the argument may come from immutable source code - (dolist (header (sort (copy-list headers) #'<)) - (cond ((null start) - (setf start header) - (setf prev header)) - ((= header (+ prev delta)) - (setf prev header)) - (t - (emit-test) - (setf start header) - (setf prev header)))) - (emit-test))) - (results))) - -;; If WIDETAGS is comprised of two ranges that are nearly adjacent, -;; return a single range spanning both original ranges, -;; and as a second value the widetag(s) to exclude; -;; or return the unmodified ranges and NIL. -;; This could be generalized: three ranges that collapse to one with at most -;; two exceptions, or three collapsing to two with one exception, etc. -(defun canonicalize-widetags+exceptions (widetags) - (let ((ranges (canonicalize-widetags widetags))) - (flet ((begin (x) (if (listp x) (car x) x)) - (end (x) (if (listp x) (cdr x) x))) - (when (and (cdr ranges) (endp (cddr ranges))) ; 2 ranges - (let* ((range-1 (first ranges)) - (range-2 (second ranges)) - (begin-1 (begin range-1)) - (end-1 (end range-1)) - (begin-2 (begin range-2)) - (end-2 (end range-2)) - (delta widetag-spacing)) - (when (and (= (+ end-1 (* 2 delta)) begin-2) - ;; Don't return {X} - {Y} if {X} spans only 3 widetags, - ;; because clearly we can just test the 2 members of X. - ;; fencepost: 3 delta is 4 widetags. - (>= (- end-2 begin-1) (* 3 delta))) - (return-from canonicalize-widetags+exceptions - (values `((,begin-1 . ,end-2)) - `(,(+ end-1 delta)))))))) ; the excluded value - (values ranges nil))) - -(defmacro test-type (value temp target not-p - (&rest type-codes) - &rest other-args - &key &allow-other-keys) - ;; Determine what interesting combinations we need to test for. - (let* ((type-codes (mapcar #'eval type-codes)) - (fixnump (and (every (lambda (lowtag) - (member lowtag type-codes)) - '#.(mapcar #'symbol-value fixnum-lowtags)) - t)) - ;; On 64-bit, UNBOUND-MARKER-WIDETAG may be smaller than LOWTAG-LIMIT - ;; but it is not a lowtag. - (lowtags (remove unbound-marker-widetag - (remove lowtag-limit type-codes :test #'<))) - (extended (remove-if (lambda (x) - (and (< x lowtag-limit) - (/= x unbound-marker-widetag))) - type-codes)) - (immediates (intersection extended +immediate-types+ :test #'eql)) - ;; To collapse the range of widetags comprising real numbers on 64-bit - ;; machines, consider SHORT-FLOAT-WIDETAG both a header and immediate. - ;; No OTHER-POINTER-LOWTAG object can ever have that header tag. - ;; But only do so if there would otherwise be a discontinuity - ;; in the set of headers. - ;; Another approach would have been to flip DOUBLE- and SINGLE- float, - ;; but that would not help NUMBERP, only REALP. Putting SINGLE- - ;; after the complex widetags would work but harm 32-bit machines. - (headers (set-difference - extended - (if (and (= n-word-bits 64) - (member (- single-float-widetag 4) extended) - (member (+ single-float-widetag 4) extended)) - (remove single-float-widetag +immediate-types+) - +immediate-types+) - :test #'eql)) - (function-p (if (intersection headers +function-widetags+) - (if (subsetp headers +function-widetags+) - t - (error "can't test for mix of function subtypes ~ - and other header types")) - nil))) - (unless type-codes - (error "At least one type must be supplied for TEST-TYPE.")) - (unless headers - (remf other-args :value-tn-ref)) - (cond - (fixnump - (when (remove-if (lambda (x) - (member x '#.(mapcar #'symbol-value fixnum-lowtags))) - lowtags) - (error "can't mix fixnum testing with other lowtags")) - (when function-p - (error "can't mix fixnum testing with function subtype testing")) - (cond - ((and (= n-word-bits 64) immediates headers) - `(%test-fixnum-immediate-and-headers ,value ,temp ,target ,not-p - ,(car immediates) - ',(canonicalize-widetags - headers) - ,@other-args)) - (immediates - (if (= n-word-bits 64) - `(%test-fixnum-and-immediate ,value ,temp ,target ,not-p - ,(car immediates) - ,@other-args) - (error "can't mix fixnum testing with other immediates"))) - (headers - `(%test-fixnum-and-headers ,value ,temp ,target ,not-p - ',(canonicalize-widetags headers) - ,@other-args)) - (t - `(%test-fixnum ,value ,temp ,target ,not-p - ,@other-args)))) - (immediates - (cond - (headers - (if (= n-word-bits 64) - `(%test-immediate-and-headers ,value ,temp ,target ,not-p - ,(car immediates) - ',(canonicalize-widetags headers) - ,@other-args) - (error "can't mix testing of immediates with testing of headers"))) - (lowtags - (error "can't mix testing of immediates with testing of lowtags")) - ((cdr immediates) - (error "can't test multiple immediates at the same time")) - (t - `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates) - ,@other-args)))) - (lowtags - (when (cdr lowtags) - (error "can't test multiple lowtags at the same time")) - (when headers - (error "can't test non-fixnum lowtags and headers at the same time")) - `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags) ,@other-args)) - (headers - `(%test-headers ,value ,temp ,target ,not-p ,function-p - ',(canonicalize-widetags headers) - ,@other-args)) - (t - (error "nothing to test?"))))) diff -Nru sbcl-2.1.1/src/compiler/generic/early-vm.lisp sbcl-2.1.11/src/compiler/generic/early-vm.lisp --- sbcl-2.1.1/src/compiler/generic/early-vm.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/early-vm.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -76,6 +76,35 @@ ;; leaving one bit for a GC mark bit. (ldb (byte (- n-word-bits n-widetag-bits 1) 0) -1)) +;;; The ANSI-specified minimum is 8. +;;; Since the array rank is stored as rank-1 in the array header, +;;; having it stop at 128 ensures that adding 1 produces an unsigned +;;; result. +(defconstant array-rank-limit 129 + "the exclusive upper bound on the rank of an array") + +;;; FIXME: these limits are wrong at the most basic level according to the spec, +;;; because if there are different limits for different element types, then +;;; this constant should be the _smallest_ of the limits for any element type. +;;; The largest element size is (COMPLEX DOUBLE-FLOAT) taking 16 bytes per element. +;;; If you had an array of this size on 32-bit machines, it would consume about +;;; 8GB of payload. So not only is it larger than a fixnum - a problem for the +;;; allocator vops - it exceeds the address space. +#-ubsan ; usual way +(progn +;;; - 2 to leave space for the array header +(defconstant array-dimension-limit (- most-positive-fixnum 2) + "the exclusive upper bound on any given dimension of an array") + +(defconstant array-total-size-limit (- most-positive-fixnum 2) + "the exclusive upper bound on the total number of elements in an array") +) + +#+ubsan ; only supported if 64-bit +(progn +(defconstant array-dimension-limit (ash 1 30)) +(defconstant array-total-size-limit (ash 1 30))) + (defconstant char-code-limit #-sb-unicode 256 #+sb-unicode #x110000 "the upper exclusive bound on values produced by CHAR-CODE") @@ -177,3 +206,82 @@ (defconstant gc-safepoint-trap-offset n-word-bytes) #+sb-xc-host (deftype sb-xc:fixnum () `(signed-byte ,n-fixnum-bits)) + +#-darwin-jit +(progn + (declaim (inline (setf sap-ref-word-jit) + (setf signed-sap-ref-32-jit) + signed-sap-ref-32-jit + (setf sap-ref-32-jit) + sap-ref-32-jit + (setf sap-ref-8-jit))) + (defun (setf sap-ref-word-jit) (value sap offset) + (setf (sap-ref-word sap offset) value)) + + (defun (setf signed-sap-ref-32-jit) (value sap offset) + (setf (signed-sap-ref-32 sap offset) value)) + + (defun signed-sap-ref-32-jit (sap offset) + (signed-sap-ref-32 sap offset)) + + (defun (setf sap-ref-32-jit) (value sap offset) + (setf (sap-ref-32 sap offset) value)) + + (defun sap-ref-32-jit (sap offset) + (sap-ref-32 sap offset)) + + #-sb-xc-host + (defun (setf sap-ref-8-jit) (value sap offset) + (setf (sap-ref-8 sap offset) value))) + +;;; Supporting code for LAYOUT allocated in metadata space a/k/a "metaspace". +;;; These objects are manually allocated and freed. +;;; Tracts are the unit of allocation requested from the OS. +;;; Following the nomenclature in https://en.wikipedia.org/wiki/Slab_allocation +;;; - A slab is the quantum requested within a tract. +;;; - Chunks are the units of allocation ("objects") within a slab. + +(defconstant metaspace-tract-size (* 2 1024 1024)) ; 2 MiB +(defconstant metaspace-slab-size 2048) ; 2 KiB + +;;; Chunks are all the same size per slab, which makes finding the next available +;;; slot simply a pop from a freelist. The object stored in the chunk can be anything +;;; not to exceed the chunk size. (You can't span chunks with one object) +;;; All slabs of a given size with any available space are kept in a doubly-linked +;;; list for the slab's chunk size. A slab is removed from the doubly-linked list and +;;; moved to the slab recycle list when all chunks within it become free. +;;; +;;; There are 4 words of overhead per slab. +;;; At present only 64-bit word size is supported, so we assume +;;; that pointer-sized words in the slab header consume 8 bytes. +;;; word 0: 2 bytes : sizeclass (as a FIXNUM) +;;; 2 bytes : capacity in objects +;;; 2 bytes : chunk size +;;; 2 bytes : number of objects allocated in it +;;; word 1: head of freelist +;;; word 2: next slab with any holes in the same sizeclass +;;; word 3: previous slab with any holes in the same sizeclass +;;; +;;; The FIXNUM representation of sizeclass causes the entire lispword +;;; to read as a fixnum, which makes it possible to map-allocated-objects +;;; over the slabs in a chunk without fuss. The slab heade appears +;;; just like 2 conses. (The next/prev pointers look like fixnums) +;;; +;;; #+big-endian will need to flip the positions of these sub-fields +;;; to make the lispword read as fixnum. + +;;; Keep in sync with the structure definition in src/runtime/alloc.c +(defconstant slab-overhead-words 4) +(defmacro slab-sizeclass (slab) `(sap-ref-16 ,slab 0)) +(defmacro slab-capacity (slab) `(sap-ref-16 ,slab 2)) +(defmacro slab-chunk-size (slab) `(sap-ref-16 ,slab 4)) +(defmacro slab-usage (slab) `(sap-ref-16 ,slab 6)) +(defmacro slab-freelist (slab) `(sap-ref-sap ,slab 8)) +(defmacro slab-next (slab) `(sap-ref-sap ,slab 16)) +(defmacro slab-prev (slab) `(sap-ref-sap ,slab 24)) +(defmacro slab-usable-range-start (slab) `(sap+ ,slab (* 4 n-word-bytes))) + +(defmacro init-slab-header (slab sizeclass chunksize capacity) + `(setf (slab-sizeclass ,slab) (ash ,sizeclass n-fixnum-tag-bits) + (slab-capacity ,slab) ,capacity + (slab-chunk-size ,slab) ,chunksize)) diff -Nru sbcl-2.1.1/src/compiler/generic/genesis.lisp sbcl-2.1.11/src/compiler/generic/genesis.lisp --- sbcl-2.1.1/src/compiler/generic/genesis.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/genesis.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -114,14 +114,6 @@ (setf (bvref bigvec i) (read-byte stream)))) -(defun read-n-bytes (stream vector start end) - (aver (zerop start)) - (let* ((start (+ (descriptor-byte-offset vector) - (ash sb-vm:vector-data-offset sb-vm:word-shift))) - (end (+ start end))) - (read-bigvec-as-sequence-or-die (descriptor-mem vector) - stream :start start :end end))) - ;;; Grow BIGVEC (exponentially, so that large increases in size have ;;; asymptotic logarithmic cost per byte). (defun expand-bigvec (bigvec required-length) @@ -191,7 +183,8 @@ (defvar *immobile-varyobj*) (defvar *immobile-space-map* nil)) -(defconstant max-core-space-id (+ 3 #+immobile-space 2)) +(defconstant max-core-space-id (+ 3 #+immobile-space 2 + #+darwin-jit 1)) (defstruct page (type nil :type (member nil :code :mixed)) @@ -205,8 +198,8 @@ ;; name and identifier for this GSPACE (name (missing-arg) :type symbol :read-only t) (identifier (missing-arg) :type fixnum :read-only t) - ;; the word address where the data will be loaded - (word-address (missing-arg) :type unsigned-byte :read-only t) + ;; the address where the data will be loaded + (byte-address (missing-arg) :type unsigned-byte :read-only t) ;; the gspace contents as a BIGVEC (data (make-bigvec) :type bigvec :read-only t) (page-table nil) ; for dynamic space @@ -215,6 +208,8 @@ ;; Each free-range is (START . LENGTH) in words. (code-free-ranges (list nil)) (non-code-free-ranges (list nil)) + ;; for metaspace + current-slab ;; Address of every object created in this space. (objects (or #+sb-devel (make-array 700000 :fill-pointer 0 :adjustable t))) ;; the index of the next unwritten word (i.e. chunk of @@ -223,8 +218,9 @@ ;; index into DATA, thus must be multiplied by SB-VM:N-WORD-BYTES. (free-word-index 0)) -(defun gspace-byte-address (gspace) - (ash (gspace-word-address gspace) sb-vm:word-shift)) +(defun gspace-upper-bound (gspace) + (+ (gspace-byte-address gspace) + (ash (gspace-free-word-index gspace) sb-vm:word-shift))) (cl:defmethod print-object ((gspace gspace) stream) (print-unreadable-object (gspace stream :type t) @@ -248,7 +244,7 @@ ;; Track page usage :page-table (if (= identifier dynamic-core-space-id) (make-array 100 :adjustable t :initial-element nil)) - :word-address (ash byte-address (- sb-vm:word-shift)) + :byte-address byte-address :free-word-index (cond #+immobile-space ((= identifier immobile-fixedobj-core-space-id) (/ sb-vm:immobile-card-bytes sb-vm:n-word-bytes)) @@ -259,23 +255,45 @@ (address 0 :type sb-vm:word) (gspace nil :type gspace)) (defun sap-int (x) (model-sap-address x)) +(defun sap+ (sap x) + (make-model-sap (+ (model-sap-address sap) x) + (model-sap-gspace sap))) (macrolet ((access (name) `(,name (gspace-data (model-sap-gspace sap)) (- (+ (model-sap-address sap) offset) (gspace-byte-address (model-sap-gspace sap)))))) (defun sap-ref-8 (sap offset) (access bvref-8)) + (defun sap-ref-16 (sap offset) (access bvref-16)) (defun sap-ref-32 (sap offset) (access bvref-32)) (defun sap-ref-64 (sap offset) (access bvref-64)) (defun signed-sap-ref-32 (sap offset) (sb-disassem:sign-extend (access bvref-32) 32)) (defun signed-sap-ref-64 (sap offset) (sb-disassem:sign-extend (access bvref-64) 64)) + (defun (setf sap-ref-16) (newval sap offset) + (setf (access bvref-16) newval)) (defun (setf sap-ref-32) (newval sap offset) (setf (access bvref-32) newval)) (defun (setf signed-sap-ref-32) (newval sap offset) (setf (access bvref-32) (ldb (byte 32 0) (the (signed-byte 32) newval)))) (defun (setf sap-ref-64) (newval sap offset) - (setf (access bvref-64) newval))) + (setf (access bvref-64) newval)) + #+darwin-jit + (progn + (defun (setf sb-vm::sap-ref-word-jit) (value sap offset) + (setf (sap-ref-64 sap offset) value)) + + (defun (setf sb-vm::signed-sap-ref-32-jit) (value sap offset) + (setf (signed-sap-ref-32 sap offset) value)) + + (defun sb-vm::signed-sap-ref-32-jit (sap offset) + (signed-sap-ref-32 sap offset)) + + (defun (setf sb-vm::sap-ref-32-jit) (value sap offset) + (setf (sap-ref-32 sap offset) value)) + + (defun sb-vm::sap-ref-32-jit (sap offset) + (sap-ref-32 sap offset)))) ;;;; representation of descriptors @@ -291,12 +309,13 @@ (= (logand lowtag 3) sb-vm:other-immediate-0-lowtag)) (defstruct (descriptor - (:constructor make-descriptor (bits &optional gspace word-offset)) + (:constructor make-descriptor (bits &optional gspace byte-offset)) (:copier nil)) ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet. (gspace nil :type (or gspace null)) - ;; the offset in words from the start of GSPACE, or NIL if not set yet - (word-offset nil :type (or sb-vm:word null)) + ;; the offset in bytes (discounting the lowtag) from the start of GSPACE, + ;; or NIL if not set yet + (byte-offset nil :type (or sb-vm:word null)) (bits 0 :read-only t :type (unsigned-byte #.sb-vm:n-machine-word-bits))) (declaim (inline descriptor=)) @@ -329,18 +348,54 @@ sb-vm:n-lowtag-bits lowtag (gspace-name (descriptor-gspace des)))) (t - (format stream "bits: #X~X" bits))))))) + (values "bits: #X~X" bits))))))) + +;;; Emulate the slab allocator. +;;; If the current slab (at the head of METASPACE-SLABS) +;;; has room, then use it. Otherwise allocate a new slab +;;; at a lower address. +(defun allocate-metaspace-layout (gspace nbytes) + (assert (= nbytes (* 8 sb-vm:n-word-bytes))) + (let ((slab (gspace-current-slab gspace))) + (flet ((init (slab) + (let ((bytes-avail (- sb-vm:metaspace-slab-size + (* sb-vm::slab-overhead-words sb-vm:n-word-bytes)))) + (sb-vm::init-slab-header + slab + 1 ; sizeclass + nbytes + ;; FIXME: Technically this should use the chunk size of the sizeclass, + ;; not the object size. But they happen to be the same in sizeclass 1. + (floor bytes-avail nbytes))) + (setf (gspace-current-slab gspace) slab))) + (unless slab + (let ((space-size (- sb-vm:read-only-space-end sb-vm:read-only-space-start)) + (slab-base (- sb-vm:read-only-space-end sb-vm:metaspace-slab-size))) + (expand-bigvec (gspace-data gspace) space-size) + (setf slab (init (make-model-sap slab-base gspace))))) + (when (= (sb-vm::slab-usage slab) (sb-vm::slab-capacity slab)) + (format t "~&Slab @ ~x is full~%" (sap-int slab)) + (setf slab (init (sap+ slab (- sb-vm:metaspace-slab-size))))) + (let* ((count (incf (sb-vm::slab-usage slab))) + (ptr (+ (sap-int slab) + (- sb-vm:metaspace-slab-size + (* count (sb-vm::slab-chunk-size slab)))))) + (make-descriptor (logior ptr sb-vm:instance-pointer-lowtag) + gspace + (- ptr (gspace-byte-address gspace))))))) ;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The ;;; free word index is boosted as necessary, and if additional memory ;;; is needed, we grow the GSPACE. The descriptor returned is a ;;; pointer of type LOWTAG. (defun allocate-cold-descriptor (gspace length lowtag &optional (page-type :mixed)) - (let* ((word-index (gspace-claim-n-bytes gspace length page-type)) - (ptr (+ (gspace-word-address gspace) word-index)) - (des (make-descriptor (logior (ash ptr sb-vm:word-shift) lowtag) - gspace - word-index))) + (let ((des + (if (and (eq gspace *read-only*) (eq lowtag sb-vm:instance-pointer-lowtag)) + (allocate-metaspace-layout gspace length) + (let* ((relative-ptr (ash (gspace-claim-n-bytes gspace length page-type) + sb-vm:word-shift)) + (ptr (+ (gspace-byte-address gspace) relative-ptr))) + (make-descriptor (logior ptr lowtag) gspace relative-ptr))))) (awhen (gspace-objects gspace) (vector-push-extend des it)) des)) @@ -371,14 +426,12 @@ (or (aref (gspace-page-table gspace) index) (setf (aref (gspace-page-table gspace) index) (make-page)))) (assign-page-types (page-type start-word-index count) - ;; CMUCL incorrectly warns that the result of ADJUST-ARRAY - ;; must not be discarded. - #+host-quirks-cmu (declare (notinline adjust-array)) (let ((start-page (page-index start-word-index)) (end-page (page-index (+ start-word-index (1- count))))) (unless (> (length (gspace-page-table gspace)) end-page) - (adjust-array (gspace-page-table gspace) (1+ end-page) - :initial-element nil)) + (setf (gspace-page-table gspace) + (adjust-array (gspace-page-table gspace) (1+ end-page) + :initial-element nil))) (loop for page-index from start-page to end-page for pte = (pte page-index) do (if (null (page-type pte)) @@ -491,21 +544,18 @@ ;;; common idioms (defun descriptor-mem (des) (gspace-data (descriptor-intuit-gspace des))) -(defun descriptor-byte-offset (des) - (ash (descriptor-word-offset des) sb-vm:word-shift)) ;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise, ;;; figure out a GSPACE which corresponds to DES, set it into ;;; (DESCRIPTOR-GSPACE DES), set a consistent value into -;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE. +;;; (DESCRIPTOR-BYTE-OFFSET DES), and return the GSPACE. (declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace)) (defun descriptor-intuit-gspace (des) (or (descriptor-gspace des) ;; gspace wasn't set, now we have to search for it. (let* ((lowtag (descriptor-lowtag des)) - (abs-word-addr (ash (- (descriptor-bits des) lowtag) - (- sb-vm:word-shift)))) + (abs-addr (- (descriptor-bits des) lowtag))) ;; Non-pointer objects don't have a gspace. (unless (or (eql lowtag sb-vm:fun-pointer-lowtag) @@ -520,14 +570,14 @@ (error "couldn't find a GSPACE for ~S" des)) ;; Bounds-check the descriptor against the allocated area ;; within each gspace. - (when (and (<= (gspace-word-address gspace) - abs-word-addr - (+ (gspace-word-address gspace) - (gspace-free-word-index gspace)))) + (when (or (<= (gspace-byte-address gspace) abs-addr (gspace-upper-bound gspace)) + (and (eq gspace *read-only*) ; KLUDGE + (<= sb-vm:read-only-space-start abs-addr + sb-vm:read-only-space-end))) ;; Update the descriptor with the correct gspace and the ;; offset within the gspace and return the gspace. - (setf (descriptor-word-offset des) - (- abs-word-addr (gspace-word-address gspace))) + (setf (descriptor-byte-offset des) + (- abs-addr (gspace-byte-address gspace))) (return (setf (descriptor-gspace des) gspace))))))) (defun descriptor-gspace-name (des) @@ -563,22 +613,15 @@ ;;; ;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or ;;; loadtime value, represented by (CONS KEYWORD ..). -(declaim (special *!cold-toplevels* *!cold-defsymbols* - *!cold-defuns* *cold-methods*)) +(declaim (special *!cold-toplevels* *!cold-defsymbols* *cold-methods*)) ;;;; miscellaneous stuff to read and write the core memory - -;; Like above, but the list is held in the target's image of the host symbol, -;; not the host's value of the symbol. -(defun cold-target-push (cold-thing host-symbol) - (cold-set host-symbol (cold-cons cold-thing (cold-symbol-value host-symbol)))) - (declaim (ftype (function (descriptor sb-vm:word) descriptor) read-wordindexed)) (macrolet ((read-bits () `(bvref-word (descriptor-mem address) - (ash (+ index (descriptor-word-offset address)) - sb-vm:word-shift)))) + (+ (descriptor-byte-offset address) + (ash index sb-vm:word-shift))))) (defun read-bits-wordindexed (address index) (read-bits)) (defun read-wordindexed (address index) @@ -587,12 +630,12 @@ (defstruct (ltv-patch (:copier nil) (:constructor make-ltv-patch (index))) (index 0 :read-only t)) -(declaim (ftype (function (descriptor sb-vm:word (or symbol descriptor ltv-patch))) +(declaim (ftype (function (descriptor sb-vm:word (or symbol package descriptor ltv-patch))) write-wordindexed)) (macrolet ((write-bits (bits) `(setf (bvref-word (descriptor-mem address) - (ash (+ index (descriptor-word-offset address)) - sb-vm:word-shift)) + (+ (descriptor-byte-offset address) + (ash index sb-vm:word-shift))) ,bits))) (defun write-wordindexed (address index value) "Write VALUE displaced INDEX words from ADDRESS." @@ -608,9 +651,11 @@ (bug "Can't patch load-time-value into ~S" address)) sb-vm:unbound-marker-widetag) (t - ;; If we're passed a symbol as a value then it needs to be interned. - (descriptor-bits (cond ((symbolp value) (cold-intern value)) - (t value))))))) + (descriptor-bits + ;; If we're passed a symbol as a value then it needs to be interned. + (cond ((symbolp value) (cold-intern value)) + ((packagep value) (cdr (cold-find-package-info (package-name value)))) + (t value))))))) (defun write-wordindexed/raw (address index bits) (declare (type descriptor address) (type sb-vm:word index) @@ -649,11 +694,6 @@ (write-header-word des (logior (ash header-data sb-vm:n-widetag-bits) widetag))) -(defun set-header-data (object data) - (write-header-data+tag object data (ldb (byte sb-vm:n-widetag-bits 0) - (read-bits-wordindexed object 0))) - object) ; return the object itself, like SB-KERNEL:SET-HEADER-DATA - (defun get-header-data (object) (ash (read-bits-wordindexed object 0) (- sb-vm:n-widetag-bits))) @@ -669,31 +709,38 @@ "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG pointing to them." (allocate-cold-descriptor gspace (ash length sb-vm:word-shift) lowtag)) -(defun allocate-header+object (gspace length widetag) - "Allocate LENGTH words plus a header word in GSPACE and - return an ``other-pointer'' descriptor to them. Initialize the header word - with the resultant length and WIDETAG." - (let ((des (allocate-cold-descriptor - gspace (ash (1+ length) sb-vm:word-shift) - sb-vm:other-pointer-lowtag))) +(defun allocate-otherptr (gspace length widetag) + "Allocate LENGTH words in GSPACE and return an ``other-pointer'' descriptor. + LENGTH must count the header word itself as 1 word. The header word is + initialized with the payload size as (1- LENGTH), and WIDETAG." + (let ((des (allocate-cold-descriptor gspace (ash length sb-vm:word-shift) + sb-vm:other-pointer-lowtag))) ;; FDEFNs don't store a length, freeing up a header byte for other use - (when (= widetag sb-vm:fdefn-widetag) - (setq length 0)) - (write-header-data+tag des length widetag) + (write-header-data+tag des (if (= widetag sb-vm:fdefn-widetag) 0 (1- length)) + widetag) des)) +(defvar *simple-vector-0-descriptor*) (defun allocate-vector (widetag length words &optional (gspace *dynamic*)) ;; Allocate a vector with WORDS payload words (excluding the header+length). ;; WORDS may be an odd number. ;; Store WIDETAG in the header and LENGTH in the length slot. - (let ((des (allocate-cold-descriptor gspace - (sb-vm:pad-data-block - (+ words sb-vm:vector-data-offset)) - sb-vm:other-pointer-lowtag))) - (write-header-data+tag des 0 widetag) - (write-wordindexed des - sb-vm:vector-length-slot - (make-fixnum-descriptor length)) - des)) + (when (and (= widetag sb-vm:simple-vector-widetag) + (= length 0) + *simple-vector-0-descriptor*) + (return-from allocate-vector *simple-vector-0-descriptor*)) + (emplace-vector (allocate-cold-descriptor + gspace + (sb-vm:pad-data-block (+ words sb-vm:vector-data-offset)) + sb-vm:other-pointer-lowtag) + widetag length)) +(defun emplace-vector (des widetag length) + #+ubsan + (write-header-word des (logior (ash length (+ 32 sb-vm:n-fixnum-tag-bits)) + widetag)) + #-ubsan + (progn (write-header-data+tag des 0 widetag) + (write-wordindexed des sb-vm:vector-length-slot (make-fixnum-descriptor length))) + des) ;;; The COLD-LAYOUT is a reflection of or proxy for the words stored ;;; in the core for a cold layout, so that we don't have to extract @@ -701,46 +748,59 @@ (defstruct (cold-layout (:constructor %make-cold-layout)) id name depthoid length bitmap flags inherits descriptor) -;;; the hosts's representation of LAYOUT-of-LAYOUT -(defvar *host-layout-of-layout* (find-layout 'layout)) - ;;; a map from name as a host symbol to the descriptor of its target layout (defvar *cold-layouts*) (defun cold-layout-descriptor-bits (name) (descriptor-bits (cold-layout-descriptor (gethash name *cold-layouts*)))) -;;; Instances whose layout needs to be backpatched -(defvar *layout-deferred-instances*) +#+compact-instance-header +(progn + ;; This is called to backpatch layout-of-layout into the primordial layouts. + (defun set-instance-layout (thing layout) + ;; High half of the header points to the layout + (write-wordindexed/raw thing 0 (logior (ash (descriptor-bits layout) 32) + (read-bits-wordindexed thing 0)))) + (defun get-instance-layout (thing) + (make-random-descriptor (ash (read-bits-wordindexed thing 0) -32)))) +#-compact-instance-header +(progn + (defun set-instance-layout (thing layout) + ;; Word following the header is the layout + (write-wordindexed thing sb-vm:instance-slots-offset layout)) + (defun get-instance-layout (thing) + (read-wordindexed thing sb-vm:instance-slots-offset))) ;; Make a structure and set the header word and layout. ;; NWORDS is the payload length (= DD-LENGTH = LAYOUT-LENGTH) -(defun allocate-struct (nwords type &optional (gspace *dynamic*)) +(defun allocate-struct (nwords layout &optional (gspace *dynamic*)) ;; Add +1 for the header word when allocating. - (let* ((object (allocate-object gspace (1+ nwords) sb-vm:instance-pointer-lowtag)) - (layout - (if (symbolp type) - (let ((layout (gethash type *cold-layouts*))) - (cond (layout - (cold-layout-descriptor layout)) - (t - (push object (gethash type *layout-deferred-instances*)) - (make-fixnum-descriptor 0)))) - type))) + (let ((object (allocate-object gspace (1+ nwords) sb-vm:instance-pointer-lowtag))) ;; Length as stored in the header is the exact number of useful words ;; that follow, as is customary. A padding word, if any is not "useful" - (write-header-word - object - (logior #+compact-instance-header (ash (descriptor-bits layout) 32) - (ash nwords sb-vm:instance-length-shift) - sb-vm:instance-widetag)) - #-compact-instance-header - (write-wordindexed object sb-vm:instance-slots-offset layout) + (write-header-word object (logior (ash nwords sb-vm:instance-length-shift) + sb-vm:instance-widetag)) + (set-instance-layout object layout) object)) +(defun type-dd-slots-or-lose (type) + (or (car (get type 'dd-proxy)) (error "NO DD-SLOTS: ~S" type))) +;;; Return the value to supply as the first argument to ALLOCATE-STRUCT +(defun struct-size (thing) + ;; ASSUMPTION: all slots consume 1 storage word + (+ sb-vm:instance-data-start (length (type-dd-slots-or-lose thing)))) (defun allocate-struct-of-type (type) - (allocate-struct (struct-size type) type)) + (allocate-struct (struct-size type) + (cold-layout-descriptor (gethash type *cold-layouts*)))) ;;;; copying simple objects into the cold core +(declaim (inline cold-vector-len)) +(defun cold-vector-len (vector) + #+ubsan (ash (read-bits-wordindexed vector 0) (- -32 sb-vm:n-fixnum-tag-bits)) + #-ubsan (descriptor-fixnum (read-wordindexed vector sb-vm:vector-length-slot))) + +(macrolet ((string-data (string-descriptor) + `(+ (descriptor-byte-offset ,string-descriptor) + (* sb-vm:vector-data-offset sb-vm:n-word-bytes)))) (defun base-string-to-core (string &optional (gspace *dynamic*)) "Copy STRING (which must only contain STANDARD-CHARs) into the cold core and return a descriptor to it." @@ -748,53 +808,53 @@ ;; extra null byte at the end to aid in call-out to C.) (let* ((length (length string)) (des (allocate-vector sb-vm:simple-base-string-widetag + ;; add SAETP-N-PAD-ELEMENT length (ceiling (1+ length) sb-vm:n-word-bytes) gspace)) - (bytes (gspace-data gspace)) - (offset (+ (* sb-vm:vector-data-offset sb-vm:n-word-bytes) - (descriptor-byte-offset des)))) - (dotimes (i length) - (setf (bvref bytes (+ offset i)) - (sb-xc:char-code (aref string i)))) - (setf (bvref bytes (+ offset length)) - 0) ; null string-termination character for C - des)) + (mem (descriptor-mem des)) + (byte-base (string-data des))) + (dotimes (i length des) ; was prezeroed, so automatically null-terminated + (setf (bvref mem (+ byte-base i)) (char-code (aref string i)))))) (defun base-string-from-core (descriptor) - (let* ((len (descriptor-fixnum - (read-wordindexed descriptor sb-vm:vector-length-slot))) - (str (make-string len)) - (bytes (descriptor-mem descriptor))) + (let* ((mem (descriptor-mem descriptor)) + (byte-base (string-data descriptor)) + (len (cold-vector-len descriptor)) + (str (make-string len))) (dotimes (i len str) - (setf (aref str i) - (code-char (bvref bytes - (+ (descriptor-byte-offset descriptor) - (* sb-vm:vector-data-offset sb-vm:n-word-bytes) - i))))))) + (setf (aref str i) (code-char (bvref mem (+ byte-base i)))))))) ;;; Write the bits of INT to core as if a bignum, i.e. words are ordered from ;;; least to most significant regardless of machine endianness. -(defun integer-bits-to-core (descriptor int nwords &optional (offset 0)) +(defun integer-bits-to-core (int descriptor start nwords) (declare (fixnum nwords)) - (do ((index 1 (1+ index)) + (do ((index 0 (1+ index)) (remainder int (ash remainder (- sb-vm:n-word-bits)))) - ((> index nwords) + ((>= index nwords) (unless (zerop (integer-length remainder)) (error "Nonzero remainder after writing ~D using ~D words" int nwords))) (write-wordindexed/raw descriptor - (+ index offset) + (+ start index) (logand remainder sb-ext:most-positive-word)))) (defun bignum-to-core (n) "Copy a bignum to the cold core." (let* ((words (ceiling (1+ (integer-length n)) sb-vm:n-word-bits)) (handle - (allocate-header+object *dynamic* words sb-vm:bignum-widetag))) - (integer-bits-to-core handle n words) + #-bignum-assertions (allocate-otherptr *dynamic* (1+ words) sb-vm:bignum-widetag) + #+bignum-assertions + (let* ((aligned-words (1+ (logior words 1))) ; round to odd, slap on a header + (physical-words (* aligned-words 2)) + (handle (allocate-otherptr *dynamic* physical-words sb-vm:bignum-widetag))) + ;; rewrite the header to indicate the logical size + (write-wordindexed/raw handle 0 (logior (ash words 8) sb-vm:bignum-widetag)) + handle))) + (integer-bits-to-core n handle sb-vm:bignum-digits-offset words) + (assert (= (bignum-from-core handle) n)) handle)) (defun bignum-from-core (descriptor) - (let ((n-words (get-header-data descriptor)) + (let ((n-words (logand (get-header-data descriptor) #x7fffff)) (val 0)) (dotimes (i n-words val) (let ((bits (read-bits-wordindexed descriptor @@ -806,7 +866,7 @@ (defun number-pair-to-core (first second type) "Makes a number pair of TYPE (ratio or complex) and fills it in." - (let ((des (allocate-header+object *dynamic* 2 type))) + (let ((des (allocate-otherptr *dynamic* 3 type))) (write-wordindexed des 1 first) (write-wordindexed des 2 second) des)) @@ -832,15 +892,13 @@ #+64-bit ; 64-bit platforms have immediate single-floats (make-random-descriptor (logior (ash bits 32) sb-vm:single-float-widetag)) #-64-bit - (let ((des (allocate-header+object *dynamic* - (1- sb-vm:single-float-size) - sb-vm:single-float-widetag))) + (let ((des (allocate-otherptr *dynamic* sb-vm:single-float-size + sb-vm:single-float-widetag))) (write-wordindexed/raw des sb-vm:single-float-value-slot bits) des))) (double-float - (let ((des (allocate-header+object *dynamic* - (1- sb-vm:double-float-size) - sb-vm:double-float-widetag))) + (let ((des (allocate-otherptr *dynamic* sb-vm:double-float-size + sb-vm:double-float-widetag))) (write-double-float-bits des sb-vm:double-float-value-slot x))))) (defun unsigned-bits-to-single-float (bits) @@ -861,20 +919,18 @@ (number-pair-to-core (number-to-core r) (number-to-core i) sb-vm:complex-widetag) (ecase (sb-impl::flonum-format r) (single-float - (let* ((des (allocate-header+object *dynamic* - (1- sb-vm:complex-single-float-size) - sb-vm:complex-single-float-widetag)) - (where (ash (+ #+64-bit sb-vm:complex-single-float-data-slot + (let* ((des (allocate-otherptr *dynamic* sb-vm:complex-single-float-size + sb-vm:complex-single-float-widetag)) + (where (+ (descriptor-byte-offset des) + (ash #+64-bit sb-vm:complex-single-float-data-slot #-64-bit sb-vm:complex-single-float-real-slot - (descriptor-word-offset des)) - sb-vm:word-shift))) + sb-vm:word-shift)))) (setf (bvref-s32 (descriptor-mem des) where) (single-float-bits r) (bvref-s32 (descriptor-mem des) (+ where 4)) (single-float-bits i)) des)) (double-float - (let ((des (allocate-header+object *dynamic* - (1- sb-vm:complex-double-float-size) - sb-vm:complex-double-float-widetag))) + (let ((des (allocate-otherptr *dynamic* sb-vm:complex-double-float-size + sb-vm:complex-double-float-widetag))) (write-double-float-bits des sb-vm:complex-double-float-real-slot r) (write-double-float-bits des sb-vm:complex-double-float-imag-slot i) des))))) @@ -930,16 +986,19 @@ (write-wordindexed result (+ index sb-vm:vector-data-offset) (pop objects))))) +(defun word-vector (objects &optional (gspace *dynamic*)) + (let* ((size (length objects)) + (result (allocate-vector #+64-bit sb-vm:simple-array-unsigned-byte-64-widetag + #-64-bit sb-vm:simple-array-unsigned-byte-32-widetag + size size gspace))) + (dotimes (index size result) + (write-wordindexed/raw result (+ index sb-vm:vector-data-offset) (pop objects))))) + (defun cold-svset (vector index value) (let ((i (if (integerp index) index (descriptor-fixnum index)))) (write-wordindexed vector (+ i sb-vm:vector-data-offset) value))) -(setf (get 'vector :sb-cold-funcall-handler/for-value) - (lambda (&rest args) (vector-in-core args))) - -(declaim (inline cold-vector-len cold-svref)) -(defun cold-vector-len (vector) - (descriptor-fixnum (read-wordindexed vector sb-vm:vector-length-slot))) +(declaim (inline cold-svref)) (defun cold-svref (vector i) (declare (type index i)) (read-wordindexed vector (+ i sb-vm:vector-data-offset))) @@ -951,6 +1010,7 @@ ;;;; symbol magic +(defvar *tls-index-to-symbol*) #+sb-thread (progn ;; Simulate *FREE-TLS-INDEX*. This is a word count, not a displacement. @@ -959,6 +1019,7 @@ ;; This is a backend support routine, but the style within this file ;; is to conditionalize by the target features. (defun cold-assign-tls-index (symbol index) + (push (list index (warm-symbol symbol)) *tls-index-to-symbol*) #+64-bit (write-wordindexed/raw symbol 0 (logior (ash index 32) (read-bits-wordindexed symbol 0))) @@ -969,11 +1030,8 @@ ;; choosing a new index if it doesn't have one yet. (defun ensure-symbol-tls-index (symbol) (let* ((cold-sym (cold-intern symbol)) - (tls-index - #+64-bit - (ldb (byte 32 32) (read-bits-wordindexed cold-sym 0)) - #-64-bit - (read-bits-wordindexed cold-sym sb-vm:symbol-tls-index-slot))) + (tls-index #+64-bit (ldb (byte 32 32) (read-bits-wordindexed cold-sym 0)) + #-64-bit (read-bits-wordindexed cold-sym sb-vm:symbol-tls-index-slot))) (unless (plusp tls-index) (let ((next (prog1 *genesis-tls-counter* (incf *genesis-tls-counter*)))) (setq tls-index (ash next sb-vm:word-shift)) @@ -985,7 +1043,7 @@ ;;; Allocate (and initialize) a symbol. (defun allocate-symbol (size name &key (gspace (symbol-value *cold-symbol-gspace*))) (declare (simple-string name)) - (let ((symbol (allocate-header+object gspace (1- size) sb-vm:symbol-widetag))) + (let ((symbol (allocate-otherptr gspace size sb-vm:symbol-widetag))) (write-wordindexed symbol sb-vm:symbol-value-slot *unbound-marker*) (write-wordindexed symbol sb-vm:symbol-hash-slot (make-fixnum-descriptor 0)) (write-wordindexed symbol sb-vm:symbol-info-slot *nil-descriptor*) @@ -1039,7 +1097,7 @@ ;;; Since we want to be able to dump structure constants and ;;; predicates with reference layouts, we need to create layouts at ;;; cold-load time. We use the name to intern layouts by, and dump a -;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system +;;; list of all cold layouts in *!INITIAL-WRAPPERS* so that type system ;;; initialization can find them. The only thing that's tricky [sic -- ;;; WHN 19990816] is initializing layout's layout, which must point to ;;; itself. @@ -1048,11 +1106,6 @@ ;;; to the host's COLD-LAYOUT proxy for that layout. (defvar *cold-layout-by-addr*) -;;; the descriptor for layout's layout (needed when making layouts) -(defvar *layout-layout*) - -(defvar *known-structure-classoids*) - ;;; Trivial methods [sic] require that we sort possible methods by the depthoid. ;;; Most of the objects printed in cold-init are ordered hierarchically in our ;;; type lattice; the major exceptions are ARRAY and VECTOR at depthoid -1. @@ -1072,43 +1125,39 @@ (acond ((gethash class-name *cold-layouts*) (cold-layout-depthoid it)) ((info :type :compiler-layout class-name) - (layout-depthoid it)) + (wrapper-depthoid it)) (t (error "Unknown depthoid for ~S" class-name)))))) -(defun type-dd-slots-or-lose (type) - (or (car (get type 'dd-proxy)) (error "NO DD-SLOTS: ~S" type))) -;;; Return the value to supply as the first argument to ALLOCATE-STRUCT -(defun struct-size (thing) - ;; ASSUMPTION: all slots consume 1 storage word - (+ sb-vm:instance-data-start (length (type-dd-slots-or-lose thing)))) - -(declaim (ftype function read-slot write-slots)) -(flet ((get-slots (host-layout-or-type) - (etypecase host-layout-or-type - (layout (dd-slots (layout-info host-layout-or-type))) - (symbol (type-dd-slots-or-lose host-layout-or-type)))) +(declaim (ftype function read-slot %write-slots write-slots)) +(flet ((infer-metadata (x) + (type-dd-slots-or-lose + (cold-layout-name (gethash (descriptor-bits (get-instance-layout x)) + *cold-layout-by-addr*)))) (find-slot (slots initarg) - (let ((dsd (find initarg slots - :test (lambda (x y) (eq x (keywordicate (dsd-name y))))))) + (let ((dsd (or (find initarg slots + :test (lambda (x y) (eq x (keywordicate (dsd-name y))))) + (error "No slot for ~S in ~S" initarg slots)))) (values (+ sb-vm:instance-slots-offset (dsd-index dsd)) (dsd-raw-type dsd))))) - (defun write-slots (cold-object host-layout-or-type &rest assignments) + (defun %write-slots (metadata cold-object &rest assignments) (aver (evenp (length assignments))) - (let ((slots (get-slots host-layout-or-type))) - (loop for (initarg value) on assignments by #'cddr - do (multiple-value-bind (index repr) (find-slot slots initarg) - (ecase repr - ((t) (write-wordindexed cold-object index value)) - ((word sb-vm:signed-word) - (write-wordindexed/raw cold-object index value)))))) + (loop for (initarg value) on assignments by #'cddr + do (multiple-value-bind (index repr) (find-slot metadata initarg) + (ecase repr + ((t) (write-wordindexed cold-object index value)) + ((word sb-vm:signed-word) + (write-wordindexed/raw cold-object index value))))) cold-object) + (defun write-slots (cold-object &rest assignments) + (apply #'%write-slots (infer-metadata cold-object) cold-object assignments)) + ;; For symmetry, the reader takes an initarg, not a slot name. - (defun read-slot (cold-object host-layout-or-type slot-initarg) + (defun read-slot (cold-object slot-initarg) (multiple-value-bind (index repr) - (find-slot (get-slots host-layout-or-type) slot-initarg) + (find-slot (infer-metadata cold-object) slot-initarg) (ecase repr ((t) (read-wordindexed cold-object index)) (word (read-bits-wordindexed cold-object index)) @@ -1135,9 +1184,11 @@ :depthoid (cadr flags+depthoid+inherits) :inherits (cddr flags+depthoid+inherits)))))))) -(defvar *simple-vector-0-descriptor*) +(defvar core-file-name) (defvar *vacuous-slot-table*) -(defvar *cold-layout-gspace* (or #+immobile-space '*immobile-fixedobj* '*dynamic*)) +(defvar *cold-layout-gspace* (or #+metaspace '*read-only* + #+immobile-space '*immobile-fixedobj* + '*dynamic*)) (declaim (ftype (function (symbol layout-depthoid integer index integer descriptor) descriptor) make-cold-layout)) @@ -1151,10 +1202,13 @@ (defvar *condition-layout-uniqueid-counter* -128) ; decremented before use (defun choose-layout-id (name conditionp) + ;; If you change these, then also change src/runtime/gc-private.h + ;; The ID of T is irrelevant since we'll never try to compare to it. (case name - ((t) 1) - (structure-object 2) - (layout 3) + ((t) 0) + (structure-object 1) + #+metaspace (wrapper 2) + (#+metaspace sb-vm:layout #-metaspace wrapper 3) (sb-lockless::list-node 4) (t (or (cdr (assq name sb-kernel::*popular-structure-types*)) (ecase sb-kernel::layout-id-type @@ -1168,65 +1222,33 @@ ;; genesis by giving them negative values which can't otherwise occur. (decf *condition-layout-uniqueid-counter*) (incf *general-layout-uniqueid-counter*)))))))) + +(defun cold-wrapper-id (wrapper-descriptor) + (let* ((layout-descriptor (->layout wrapper-descriptor)) + (proxy (gethash (descriptor-bits layout-descriptor) *cold-layout-by-addr*))) + (cold-layout-id proxy))) + (defun make-cold-layout (name depthoid flags length bitmap inherits) ;; Layouts created in genesis can't vary in length due to the number of ancestor ;; types in the IS-A vector. They may vary in length due to the bitmap word count. ;; But we can at least assert that there is one less thing to worry about. (aver (<= depthoid sb-kernel::layout-id-vector-fixed-capacity)) - (let* ((fixed-words (sb-kernel::type-dd-length layout)) + (let* ((fixed-words (sb-kernel::type-dd-length sb-vm:layout)) (bitmap-words (ceiling (1+ (integer-length bitmap)) sb-vm:n-word-bits)) (result (allocate-struct (+ fixed-words bitmap-words) - *layout-layout* + (or (awhen (gethash #+metaspace 'sb-vm:layout + #-metaspace 'wrapper *cold-layouts*) + (cold-layout-descriptor it)) + (make-fixnum-descriptor 0)) (symbol-value *cold-layout-gspace*))) - (this-id (choose-layout-id name (logtest flags +condition-layout-flag+)))) - #+64-bit - (write-slots result *host-layout-of-layout* - :flags (sb-kernel::pack-layout-flags depthoid length flags)) - #-64-bit - (write-slots result *host-layout-of-layout* - :depthoid (make-fixnum-descriptor depthoid) - :length (make-fixnum-descriptor length) - :flags flags) - - ;; Set other slot values. - ;; leave CLASSOID uninitialized for now - (write-slots result *host-layout-of-layout* - :clos-hash (make-fixnum-descriptor (sb-impl::hash-layout-name name)) - :invalid *nil-descriptor* - :inherits inherits - :%info *nil-descriptor*) - - (awhen (gethash name *layout-deferred-instances*) - (format t "~&Patching layout for ~S into ~D instance~:P~%" - name (length it)) - (dolist (instance it (remhash name *layout-deferred-instances*)) - (set-instance-layout instance result))) - - (when (member name '(null list symbol pathname)) - ;; Assign an empty slot-table. Why this is done only for four - ;; classoids is ... too complicated to explain here in a few words, - ;; but revision 18c239205d9349abc017b07e7894a710835c5205 broke it. - ;; Keep this in sync with MAKE-SLOT-TABLE in pcl/slots-boot. - (write-slots result *host-layout-of-layout* - :slot-table (if (boundp '*vacuous-slot-table*) - *vacuous-slot-table* - (setq *vacuous-slot-table* - (host-constant-to-core '#(1 nil)))))) - - (if (not (logtest flags +structure-layout-flag+)) - (write-slots result *host-layout-of-layout* :id-word0 this-id) - (let ((byte-offset (ash (+ (descriptor-word-offset result) - (get-dsd-index sb-kernel:layout sb-kernel::id-word0) - sb-vm:instance-slots-offset) - sb-vm:word-shift))) - (loop for i from 2 below (cold-vector-len inherits) - do (setf (bvref-s32 (descriptor-mem result) byte-offset) - (cold-layout-id (gethash (descriptor-bits (cold-svref inherits i)) - *cold-layout-by-addr*))) - (incf byte-offset 4)) - (setf (bvref-s32 (descriptor-mem result) byte-offset) this-id))) - - (integer-bits-to-core result bitmap bitmap-words fixed-words) + (wrapper + #-metaspace result ; WRAPPER and LAYOUT are synonymous in this case + #+metaspace (allocate-struct (sb-kernel::type-dd-length wrapper) + (or (awhen (gethash 'wrapper *cold-layouts*) + (cold-layout-descriptor it)) + (make-fixnum-descriptor 0)))) + (this-id (choose-layout-id name (logtest flags +condition-layout-flag+))) + (hash (make-fixnum-descriptor (sb-impl::hash-layout-name name)))) (let ((proxy (%make-cold-layout :id this-id :name name @@ -1240,13 +1262,62 @@ ;; by name or by descriptor-bits. (setf (gethash (descriptor-bits result) *cold-layout-by-addr*) proxy (gethash name *cold-layouts*) proxy)) + (unless core-file-name (return-from make-cold-layout result)) + + ;; Can't use the easier WRITE-SLOTS unfortunately because bootstrapping is hard + (let* ((wrapper-metadata (type-dd-slots-or-lose 'wrapper)) + (layout-metadata #-metaspace wrapper-metadata + #+metaspace (type-dd-slots-or-lose 'sb-vm:layout))) + + #+64-bit + (%write-slots layout-metadata result + :flags (sb-kernel::pack-layout-flags depthoid length flags)) + #-64-bit + (%write-slots layout-metadata result + :depthoid (make-fixnum-descriptor depthoid) + :length (make-fixnum-descriptor length) + :flags flags) + + (%write-slots wrapper-metadata wrapper + :clos-hash hash + :invalid *nil-descriptor* + :inherits inherits + :%info *nil-descriptor*) + + (when (member name '(null list symbol pathname)) + ;; Assign an empty slot-table. Why this is done only for four + ;; classoids is ... too complicated to explain here in a few words, + ;; but revision 18c239205d9349abc017b07e7894a710835c5205 broke it. + ;; Keep this in sync with MAKE-SLOT-TABLE in pcl/slots-boot. + (%write-slots wrapper-metadata wrapper + :slot-table (if (boundp '*vacuous-slot-table*) + *vacuous-slot-table* + (setq *vacuous-slot-table* + (host-constant-to-core '#(1 nil)))))) + + ;; If wrappers are used, the wrapper has a copy of the hash, + ;; and also the two friends point to each other. + #+metaspace + (progn (%write-slots layout-metadata result :clos-hash hash :friend wrapper) + (%write-slots wrapper-metadata wrapper :friend result)) + + (let ((byte-offset (+ (descriptor-byte-offset result) (sb-vm::id-bits-offset)))) + (when (logtest flags +structure-layout-flag+) + (loop for i from 2 below (cold-vector-len inherits) + do (setf (bvref-s32 (descriptor-mem result) byte-offset) + (cold-wrapper-id (cold-svref inherits i))) + (incf byte-offset 4))) + (setf (bvref-s32 (descriptor-mem result) byte-offset) this-id))) + + (integer-bits-to-core bitmap result (1+ fixed-words) bitmap-words) + result)) (defun predicate-for-specializer (type-name) (let ((classoid (find-classoid type-name nil))) (typecase classoid (structure-classoid - (dd-predicate-name (layout-info (classoid-layout classoid)))) + (dd-predicate-name (sb-kernel::wrapper-%info (classoid-wrapper classoid)))) (built-in-classoid (let ((translation (specifier-type type-name))) (aver (not (contains-unknown-type-p translation))) @@ -1266,8 +1337,7 @@ (declare (type ctype obj)) (if (classoid-p obj) (let* ((cell (cold-find-classoid-cell (classoid-name obj) :create t)) - (cold-classoid - (read-slot cell (find-layout 'sb-kernel::classoid-cell) :classoid))) + (cold-classoid (read-slot cell :classoid))) (aver (not (sb-kernel::undefined-classoid-p obj))) (unless (cold-null cold-classoid) (return-from ctype-to-core cold-classoid))) @@ -1286,8 +1356,7 @@ (if (classoid-p obj) ;; Place this classoid into its clasoid-cell. (let ((cell (cold-find-classoid-cell (classoid-name obj) :create t))) - (write-slots cell (find-layout 'sb-kernel::classoid-cell) - :classoid result)) + (write-slots cell :classoid result)) ;; Otherwise put it in the general cache (setf (gethash specifier *ctype-cache*) result)) result)) @@ -1301,12 +1370,21 @@ ;; trivially dumpable constant in lieu of whatever complicated ;; substructure it currently holds. (typecase obj - (classoid - `((,(get-dsd-index built-in-classoid sb-kernel::subclasses) . nil) - ;; Even though (gethash (classoid-name obj) *cold-layouts*) may exist, - ;; we nonetheless must set LAYOUT to NIL or else warm build fails - ;; in the twisty maze of class initializations. - (,(get-dsd-index built-in-classoid layout) . nil))))) + (classoid + (let ((slots-to-omit + `(;; :predicate will be patched in during cold init. + (,(get-dsd-index built-in-classoid sb-kernel::predicate) . + ,(make-random-descriptor sb-vm:unbound-marker-widetag)) + (,(get-dsd-index classoid sb-kernel::subclasses) . nil) + ;; Even though (gethash (classoid-name obj) *cold-layouts*) may exist, + ;; we nonetheless must set LAYOUT to NIL or else warm build fails + ;; in the twisty maze of class initializations. + (,(get-dsd-index classoid wrapper) . nil)))) + (if (typep obj 'built-in-classoid) + slots-to-omit + ;; :predicate is not a slot. Don't mess up the object + ;; by omitting a slot at the same index as it. + (cdr slots-to-omit)))))) (dd-slots (type-dd-slots-or-lose host-type)) ;; ASSUMPTION: all slots consume 1 storage word (dd-len (+ sb-vm:instance-data-start (length dd-slots))) @@ -1315,52 +1393,52 @@ (do ((index sb-vm:instance-data-start (1+ index))) ((= index dd-len) result) (let* ((dsd (find index dd-slots :key #'dsd-index)) - (host-val (funcall (dsd-accessor-name dsd) obj)) - (override (assq index simple-slots))) + (override (assq index simple-slots)) + (reader (dsd-accessor-name dsd))) (ecase (dsd-raw-type dsd) ((t) (write-wordindexed result (+ sb-vm:instance-slots-offset index) (if override (or (cdr override) *nil-descriptor*) - (host-constant-to-core host-val obj-to-core-helper)))) + (host-constant-to-core (funcall reader obj) + obj-to-core-helper)))) ((word sb-vm:signed-word) (write-wordindexed/raw result (+ sb-vm:instance-slots-offset index) - (or (cdr override) host-val)))))))) + (or (cdr override) (funcall reader obj))))))))) -;; This is called to backpatch two small sets of objects: -;; - layouts created before layout-of-layout is made (3 counting LAYOUT itself) -;; - a small number of classoid-cells (~ 4). -(defun set-instance-layout (thing layout) - #+compact-instance-header - ;; High half of the header points to the layout - (write-wordindexed/raw thing 0 (logior (ash (descriptor-bits layout) 32) - (read-bits-wordindexed thing 0))) - #-compact-instance-header - ;; Word following the header is the layout - (write-wordindexed thing sb-vm:instance-slots-offset layout)) +;;; Convert a layout to a wrapper and back. +;;; Each points to the other through its first data word. +(defun ->wrapper (x) #+metaspace (read-wordindexed x 1) #-metaspace x) +(defun ->layout (x) #+metaspace (read-wordindexed x 1) #-metaspace x) (defun initialize-layouts () - (setq *layout-layout* (make-fixnum-descriptor 0)) - (let ((l (find-layout 'stream))) - (setf (layout-flags l) (logior (logior (layout-flags l)) +stream-layout-flag+))) (flet ((chill-layout (name &rest inherits) ;; Check that the number of specified INHERITS matches ;; the length of the layout's inherits in the cross-compiler. - (let ((warm-layout (info :type :compiler-layout name))) - (assert (eql (length (layout-inherits warm-layout)) + (let ((wrapper (info :type :compiler-layout name))) + (assert (eql (length (wrapper-inherits wrapper)) (length inherits))) - (make-cold-layout name - (layout-depthoid warm-layout) - (layout-flags warm-layout) - (layout-length warm-layout) - (layout-bitmap warm-layout) - (vector-in-core inherits))))) + (->wrapper + (make-cold-layout name + (wrapper-depthoid wrapper) + (wrapper-flags wrapper) + (wrapper-length wrapper) + (wrapper-bitmap wrapper) + (vector-in-core inherits)))))) + ;; The variables are named foo-LAYOUT but are actually foo-WRAPPER. (let* ((t-layout (chill-layout 't)) - (s-o-layout (chill-layout 'structure-object t-layout))) - (setf *layout-layout* (chill-layout 'layout t-layout s-o-layout)) - (dolist (layout (list t-layout s-o-layout *layout-layout*)) - (set-instance-layout layout *layout-layout*)) + (s-o-layout (chill-layout 'structure-object t-layout)) + #+metaspace (layout-layout (chill-layout 'sb-vm:layout t-layout s-o-layout)) + (wrapper-layout (chill-layout 'wrapper t-layout s-o-layout))) + (when core-file-name + #-metaspace + (dolist (instance (list t-layout s-o-layout wrapper-layout)) + (set-instance-layout instance wrapper-layout)) + #+metaspace + (progn (dolist (instance (list t-layout s-o-layout layout-layout wrapper-layout)) + (set-instance-layout instance (->layout wrapper-layout)) + (set-instance-layout (->layout instance) (->layout layout-layout))))) (chill-layout 'function t-layout) (chill-layout 'sb-kernel::classoid-cell t-layout s-o-layout) (chill-layout 'package t-layout s-o-layout) @@ -1377,32 +1455,30 @@ (defvar *cold-package-symbols*) (declaim (type hash-table *cold-package-symbols*)) -(setf (get 'find-package :sb-cold-funcall-handler/for-value) - (lambda (descriptor &aux (name (base-string-from-core descriptor))) - (or (cdr (gethash name *cold-package-symbols*)) - (error "Genesis could not find a target package named ~S" name)))) +(defun cold-find-package-info (package-name) + (or (gethash package-name *cold-package-symbols*) + (error "Genesis could not find a target package named ~S" package-name))) (defvar *classoid-cells*) (defun cold-find-classoid-cell (name &key create) (aver (eq create t)) (or (gethash name *classoid-cells*) - (let ((host-layout (find-layout 'sb-kernel::classoid-cell))) - (setf (gethash name *classoid-cells*) - (write-slots (allocate-struct-of-type 'sb-kernel::classoid-cell) - host-layout - :name name - :pcl-class *nil-descriptor* - :classoid *nil-descriptor*))))) - -(setf (get 'find-classoid-cell :sb-cold-funcall-handler/for-value) - #'cold-find-classoid-cell) + (setf (gethash name *classoid-cells*) + (write-slots (allocate-struct-of-type 'sb-kernel::classoid-cell) + :name name + :pcl-class *nil-descriptor* + :classoid *nil-descriptor*)))) ;;; a map from descriptors to symbols, so that we can back up. The key ;;; is the address in the target core. (defvar *cold-symbols*) (declaim (type hash-table *cold-symbols*)) -(defun set-readonly (string) (set-header-data string sb-vm:+vector-shareable+)) +(defun set-readonly (vector) + (write-wordindexed/raw vector 0 (logior (read-bits-wordindexed vector 0) + (ash sb-vm:+vector-shareable+ + sb-vm:array-flags-position))) + vector) (defun initialize-packages () (let ((package-data-list @@ -1416,14 +1492,13 @@ :name "COMMON-LISP-USER" :doc nil :use '("COMMON-LISP" "SB-ALIEN" "SB-DEBUG" "SB-EXT" "SB-GRAY" "SB-PROFILE")) (sb-cold::package-list-for-genesis))) - (package-layout (find-layout 'package)) (target-pkg-list nil)) (labels ((init-cold-package (name &optional docstring) (let ((cold-package (allocate-struct-of-type 'package))) (setf (gethash name *cold-package-symbols*) (cons (cons nil nil) cold-package)) ;; Initialize string slots - (write-slots cold-package package-layout + (write-slots cold-package :%name (set-readonly (base-string-to-core name)) :%nicknames (chill-nicknames name) @@ -1474,12 +1549,10 @@ (let ((cell (find-package-cell that))) (push (cadr cell) use) (push this (cddr cell)))) - (write-slots this package-layout - :%use-list (list-to-core (nreverse use))))) + (write-slots this :%use-list (list-to-core (nreverse use))))) ;; pass 3: set the 'used-by' lists (dolist (cell target-pkg-list) - (write-slots (cadr cell) package-layout - :%used-by-list (list-to-core (cddr cell)))) + (write-slots (cadr cell) :%used-by-list (list-to-core (cddr cell)))) ;; finally, assign *PACKAGE* since it supposed to be always-bound ;; and various things assume that it is. e.g. FIND-PACKAGE has an ;; (IF (BOUNDP '*PACKAGE*)) test which the compiler elides. @@ -1534,7 +1607,6 @@ ;;; Return a handle on an interned symbol. If necessary allocate the ;;; symbol and record its home package. -(defvar core-file-name) (defun cold-intern (symbol &key (access nil) (gspace (symbol-value *cold-symbol-gspace*)) @@ -1577,8 +1649,7 @@ ;; All interned symbols need a hash (write-wordindexed handle sb-vm:symbol-hash-slot (make-fixnum-descriptor (sb-xc:sxhash symbol))) - (let ((pkg-info (or (gethash (package-name package) *cold-package-symbols*) - (error "No target package descriptor for ~S" package)))) + (let ((pkg-info (cold-find-package-info (package-name package)))) (write-wordindexed handle sb-vm:symbol-package-slot (cdr pkg-info)) (record-accessibility (or access (nth-value 1 (find-symbol name package))) @@ -1606,14 +1677,13 @@ #+64-bit sb-vm:simple-array-signed-byte-64-widetag 6 6 *static*) #+64-bit (setf (gspace-free-word-index *static*) (/ 256 sb-vm:n-word-bytes)) - (let* ((des (allocate-header+object *static* sb-vm:symbol-size 0)) + (let* ((des (allocate-otherptr *static* (1+ sb-vm:symbol-size) 0)) (nil-val (make-descriptor (+ (descriptor-bits des) (* 2 sb-vm:n-word-bytes) (- sb-vm:list-pointer-lowtag - ;; ALLOCATE-HEADER+OBJECT always adds in + ;; ALLOCATE-OTHERPTR always adds in ;; OTHER-POINTER-LOWTAG, so subtract it. sb-vm:other-pointer-lowtag)))) - (header (make-other-immediate-descriptor 0 sb-vm:symbol-widetag)) (initial-info (cold-cons nil-val nil-val)) ;; NIL's name is in dynamic space because any extra bytes allocated ;; in static space need to be accounted for by STATIC-SYMBOL-OFFSET. @@ -1646,7 +1716,7 @@ ;; the above sequence would not necessarily decrease the instruction count! (write-wordindexed des 0 (make-fixnum-descriptor 0)) - (write-wordindexed des 1 header) + (write-wordindexed des 1 (make-other-immediate-descriptor 0 sb-vm:symbol-widetag)) (write-wordindexed des (+ 1 sb-vm:symbol-value-slot) nil-val) (write-wordindexed des (+ 1 sb-vm:symbol-hash-slot) nil-val) (write-wordindexed des (+ 1 sb-vm:symbol-info-slot) initial-info) @@ -1699,7 +1769,10 @@ sb-vm:symbol-value-slot (ash (cold-layout-descriptor-bits 'function) 32)) - #+immobile-space + #+metaspace + (cold-set '**primitive-object-layouts** + (allocate-vector sb-vm:simple-vector-widetag 256 256 *read-only*)) + #+(and immobile-space (not metaspace)) (cold-set '**primitive-object-layouts** (let ((filler (make-random-descriptor @@ -1711,14 +1784,11 @@ sb-vm:immobile-card-bytes (* (+ 2 256) (- sb-vm:n-word-bytes))) sb-vm:other-pointer-lowtag)))) - (write-header-word filler sb-vm:simple-array-fixnum-widetag) - (write-wordindexed filler 1 - (make-fixnum-descriptor - (- (/ sb-vm:immobile-card-bytes sb-vm:n-word-bytes) - ;; subtract 2 object headers + 256 words - (+ 4 256)))) - (write-header-word vector sb-vm:simple-vector-widetag) - (write-wordindexed vector 1 (make-fixnum-descriptor 256)) + (emplace-vector filler sb-vm:simple-array-fixnum-widetag + (- (/ sb-vm:immobile-card-bytes sb-vm:n-word-bytes) + ;; subtract 2 object headers + 256 words + (+ 4 256))) + (emplace-vector vector sb-vm:simple-vector-widetag 256) vector)) ;; Immobile code prefers all FDEFNs adjacent so that code can be located @@ -1760,11 +1830,11 @@ ;;; Establish initial values for magic symbols. ;;; (defun finish-symbols () - (cold-set '*!initial-layouts* + (cold-set 'sb-kernel::*!initial-wrappers* (vector-in-core (mapcar (lambda (pair) (cold-cons (cold-intern (car pair)) - (cold-layout-descriptor (cdr pair)))) + (->wrapper (cold-layout-descriptor (cdr pair))))) (sort-cold-layouts)))) ;; MAKE-LAYOUT uses ATOMIC-INCF which returns the value in the cell prior to ;; increment, so we need to add 1 to get to the next value for it because @@ -1779,11 +1849,21 @@ (sort (%hash-table-alist *ctype-cache*) #'< :key (lambda (x) (descriptor-bits (cdr x))))))) + ;; Consume the rest of read-only-space as metaspace + #+metaspace + (let* ((space *read-only*) + (slab (gspace-current-slab space))) + (cold-set 'sb-vm::*metaspace-tracts* + (word-vector (list (+ sb-vm::read-only-space-start 32768) ; KLUDGE + (sap-int slab) + sb-vm:read-only-space-end + 0)))) + #+sb-thread (cold-set 'sb-vm::*free-tls-index* (make-descriptor (ash *genesis-tls-counter* sb-vm:word-shift))) - (cold-set '*code-serialno* (make-fixnum-descriptor (1+ *code-serialno*))) + (cold-set 'sb-c::*code-serialno* (make-fixnum-descriptor (1+ sb-c::*code-serialno*))) ;; Put the C-callable fdefns into the static-fdefn vector if #+immobile-code. #+immobile-code @@ -1824,8 +1904,7 @@ (package-shadowing-symbols (find-package pkg-name)) :key #'cl:symbol-package) #'string<)))) - (write-slots (cdr pkg-info) ; package - (find-layout 'package) + (write-slots (cdr pkg-info) :%shadowing-symbols (list-to-core (mapcar 'cold-intern shadow)))) (unless (member pkg-name '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD") @@ -1850,7 +1929,7 @@ (sort (%hash-table-alist *cold-package-symbols*) #'string< :key #'car)))) ; Sort by package-name - (dump-symbol-info-vectors + (dump-symbol-infos (attach-fdefinitions-to-symbols (attach-classoid-cells-to-symbols (make-hash-table :test #'eq)))) @@ -1937,7 +2016,7 @@ (declare (type (or symbol descriptor) cold-name)) (let ((warm-name (warm-fun-name cold-name))) (or (gethash warm-name *cold-fdefn-objects*) - (let ((fdefn (allocate-header+object gspace (1- sb-vm:fdefn-size) sb-vm:fdefn-widetag))) + (let ((fdefn (allocate-otherptr gspace sb-vm:fdefn-size sb-vm:fdefn-widetag))) (setf (gethash warm-name *cold-fdefn-objects*) fdefn) #+x86-64 (write-wordindexed/raw ; write an INT instruction into the header @@ -1961,34 +2040,25 @@ (- sb-vm:fun-pointer-lowtag) (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift))) -;;; Handle a DEFUN in cold-load. -(defun cold-fset (name function &optional inline-expansion dxable-args) - (binding* (((cold-name warm-name) - ;; (SETF f) was descriptorized when dumped, symbols were not. - (if (symbolp name) - (values (cold-intern name) name) - (values name (warm-fun-name name)))) - (fdefn (cold-fdefinition-object cold-name))) - (unless (cold-null (cold-fdefn-fun fdefn)) - (error "Duplicate DEFUN for ~S" warm-name)) - ;; There can't be any closures or funcallable instances. - (aver (= (logand (read-bits-wordindexed function 0) sb-vm:widetag-mask) - sb-vm:simple-fun-widetag)) - (push (cold-list cold-name inline-expansion dxable-args) *!cold-defuns*) - (write-wordindexed fdefn sb-vm:fdefn-fun-slot function) - (let ((fun-entry-addr - (+ (logandc2 (descriptor-bits function) sb-vm:lowtag-mask) - (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift)))) - (declare (ignorable fun-entry-addr)) ; sparc and arm don't need - #+x86-64 - (write-wordindexed/raw ; write a JMP instruction into the header - fdefn 0 (dpb #x1025FF (byte 24 16) (read-bits-wordindexed fdefn 0))) - (write-wordindexed/raw - fdefn sb-vm:fdefn-raw-addr-slot - (or #+(or sparc arm riscv) ; raw addr is the function descriptor - (descriptor-bits function) - ;; For all others raw addr is the starting address - fun-entry-addr))) +(defun cold-fset (name defn) + (aver (= (logand (read-bits-wordindexed defn 0) sb-vm:widetag-mask) + sb-vm:simple-fun-widetag)) + (let ((fdefn (cold-fdefinition-object + ;; (SETF f) was descriptorized when dumped, symbols were not. + (if (symbolp name) + (cold-intern name) + name)))) + (write-wordindexed fdefn sb-vm:fdefn-fun-slot defn) + #+x86-64 + (write-wordindexed/raw ; write a JMP instruction into the header + fdefn 0 (dpb #x1025FF (byte 24 16) (read-bits-wordindexed fdefn 0))) + (write-wordindexed/raw + fdefn sb-vm:fdefn-raw-addr-slot + (or #+(or sparc arm riscv) ; raw addr is the function descriptor + (descriptor-bits defn) + ;; For all others raw addr is the starting address + (+ (logandc2 (descriptor-bits defn) sb-vm:lowtag-mask) + (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift)))) fdefn)) ;;; Handle a DEFMETHOD in cold-load. "Very easily done". Right. @@ -2002,8 +2072,7 @@ (defun attach-classoid-cells-to-symbols (hashtable) (when (plusp (hash-table-count *classoid-cells*)) - (aver (cold-layout-descriptor - (gethash 'sb-kernel::classoid-cell *cold-layouts*))) + (aver (gethash 'sb-kernel::classoid-cell *cold-layouts*)) (let ((type-classoid-cell-info (sb-c::meta-info-number (sb-c::meta-info :type :classoid-cell))) (type-kind-info @@ -2019,9 +2088,7 @@ ;; unless the :KIND is set, but we can't set the kind ;; to :INSTANCE unless the classoid is present in the cell. (when (and (eq (info :type :kind symbol) :instance) - (not (cold-null (read-slot cold-classoid-cell - 'sb-kernel::classoid-cell - :classoid)))) + (not (cold-null (read-slot cold-classoid-cell :classoid)))) (setf packed-info (packed-info-insert packed-info sb-impl::+no-auxiliary-key+ @@ -2034,7 +2101,7 @@ ;; (defun attach-fdefinitions-to-symbols (hashtable) ;; Collect fdefinitions that go with one symbol, e.g. CAR and (SETF CAR), - ;; using the host's code for manipulating a packed info-vector. + ;; using the host's code for manipulating a packed-info. (maphash (lambda (warm-name cold-fdefn) (with-globaldb-name (key1 key2) warm-name :hairy (error "Hairy fdefn name in genesis: ~S" warm-name) @@ -2046,24 +2113,33 @@ *cold-fdefn-objects*) hashtable) -(defun dump-symbol-info-vectors (hashtable) - ;; Emit in the same order symbols reside in core to avoid - ;; sensitivity to the iteration order of host's maphash. - (loop for (warm-sym . info) +(defun dump-packed-info (list) + ;; Payload length is the element count + LAYOUT slot if necessary. + ;; Header word is added automatically by ALLOCATE-STRUCT + (let ((s (allocate-struct (+ sb-vm:instance-data-start (length list)) + (cold-layout-descriptor (gethash 'packed-info *cold-layouts*))))) + (loop for i from (+ sb-vm:instance-slots-offset sb-vm:instance-data-start) + for elt in list do (write-wordindexed s i elt)) + s)) +(defun dump-symbol-infos (hashtable) + (cold-set 'sb-impl::+nil-packed-infos+ + (dump-packed-info (list (make-fixnum-descriptor 0)))) + ;; Emit in the same order symbols reside in core to avoid + ;; sensitivity to the iteration order of host's maphash. + (loop for (warm-sym . info) in (sort (%hash-table-alist hashtable) #'< :key (lambda (x) (descriptor-bits (cold-intern (car x))))) do (write-wordindexed (cold-intern warm-sym) sb-vm:symbol-info-slot - ;; Each vector will have one fixnum, possibly the symbol SETF, + (dump-packed-info + ;; Each packed-info will have one fixnum, possibly the symbol SETF, ;; and one or two # objects in it, and/or a classoid-cell. - (vector-in-core (map 'list (lambda (elt) (etypecase elt (symbol (cold-intern elt)) - (fixnum (make-fixnum-descriptor elt)) + (sb-xc:fixnum (make-fixnum-descriptor elt)) (descriptor elt))) - info))))) - + (sb-impl::packed-info-cells info)))))) ;;;; fixups and related stuff @@ -2085,13 +2161,10 @@ (defun code-header-words (code-object) ; same, but expressed in words (ash (code-header-bytes code-object) (- sb-vm:word-shift))) -(declaim (inline calculate-code-insts-address)) -(defun calc-code-insts-address (code) - (+ (descriptor-bits code) - (- sb-vm:other-pointer-lowtag) - (code-header-bytes code))) (defun code-instructions (code) - (make-model-sap (calc-code-insts-address code) (descriptor-gspace code))) + (make-model-sap (- (+ (descriptor-bits code) (code-header-bytes code)) + sb-vm:other-pointer-lowtag) + (descriptor-gspace code))) ;;; These are fairly straightforward translations of the similarly named accessor ;;; from src/code/simple-fun.lisp @@ -2111,14 +2184,11 @@ #+little-endian (ldb (byte 16 0) word) #+big-endian (ldb (byte 16 16) word))) -;;; These three are literally identical between cross-compiler and target. +;;; These are literally identical between cross-compiler and target. ;;; TODO: Maybe put them somewhere that gets defined for both? ;;; (Minor problem of CODE-COMPONENT not being a primitive type though) (defun code-n-entries (code) (ash (code-fun-table-count code) -4)) -(defun code-fdefns-start-index (code) - (+ sb-vm:code-constants-offset - (* (code-n-entries code) sb-vm:code-slots-per-simple-fun))) (defun %code-fun-offset (code fun-index) ;; The 4-byte quantity at "END" - 4 is the trailer count, the word at -8 is ;; the offset to the 0th simple-fun, -12 is the next, etc... @@ -2145,7 +2215,6 @@ ;;; In case we need to store code fixups in code objects. ;;; At present only the x86 backends use this (defvar *code-fixup-notes*) -(defvar *allocation-point-fixup-notes*) (defun code-jump-table-words (code) (ldb (byte 14 0) (read-bits-wordindexed code (code-header-words code)))) @@ -2156,9 +2225,11 @@ descriptor) cold-fixup)) (defun cold-fixup (code-object after-header value kind flavor) - (when (sb-vm:fixup-code-object code-object after-header value kind flavor) - (push (cons kind after-header) - (gethash (descriptor-bits code-object) *code-fixup-notes*))) + (let ((classification + (sb-vm:fixup-code-object code-object after-header value kind flavor))) + (when classification + (push (cons classification after-header) + (gethash (descriptor-bits code-object) *code-fixup-notes*)))) code-object) (defun resolve-static-call-fixups () @@ -2168,16 +2239,17 @@ (cold-fun-entry-addr (cold-symbol-function name)) kind :static-call)))) -;;; Save packed lists of absolute and relative fixups. +;;; Save packed lists of fixups. ;;; (cf. FINISH-FIXUPS in generic/target-core.) (defun repack-fixups (list) - (collect ((relative) (absolute)) + (collect ((immediate) (relative) (absolute)) (dolist (item list) (ecase (car item) ;; There should be no absolute64 fixups to preserve + (:immediate (immediate (cdr item))) (:relative (relative (cdr item))) (:absolute (absolute (cdr item))))) - (number-to-core (sb-c:pack-code-fixup-locs (absolute) (relative))))) + (number-to-core (sb-c:pack-code-fixup-locs (absolute) (relative) (immediate))))) (defun linkage-table-note-symbol (symbol-name datap) "Register a symbol and return its address in proto-linkage-table." @@ -2259,28 +2331,29 @@ (define-cold-fop (fop-misc-trap) *unbound-marker*) (define-cold-fop (fop-struct (size)) ; n-words incl. layout, excluding header - (let* ((layout (pop-stack)) - (proxy-layout ; our host-structure wrapper on the slots of the cold layout - (gethash (descriptor-bits layout) *cold-layout-by-addr*)) + (let* ((layout (->layout (pop-stack))) (result (allocate-struct size layout)) - (bitmap (cold-layout-bitmap proxy-layout))) - (loop for index downfrom (1- size) to sb-vm:instance-data-start - for val = (pop-stack) then (pop-stack) - do (let ((dsd-index (+ sb-vm:instance-slots-offset index))) - (if (logbitp index bitmap) - (write-wordindexed result dsd-index val) - (write-wordindexed/raw - result dsd-index - (the sb-vm:word (descriptor-integer val)))))) - result)) + (bitmap (cold-layout-bitmap (gethash (descriptor-bits layout) *cold-layout-by-addr*))) + (stack (%fasl-input-stack (fasl-input))) + (n-data-words (- size sb-vm:instance-data-start))) + (do ((stack-index (fop-stack-pop-n stack n-data-words) (1+ stack-index)) + (dsd-index sb-vm:instance-data-start (1+ dsd-index))) + ((>= dsd-index size)) + (let ((val (svref stack stack-index))) + (if (logbitp dsd-index bitmap) + (write-wordindexed result (+ sb-vm:instance-slots-offset dsd-index) val) + (write-wordindexed/raw result (+ sb-vm:instance-slots-offset dsd-index) + (the sb-vm:word (descriptor-integer val)))))) + result)) (defun find-in-inherits (typename inherits) - (dotimes (i (cold-vector-len inherits)) - (let ((proxy (gethash (descriptor-bits (cold-svref inherits i)) - *cold-layout-by-addr*))) - (when (eq (cold-layout-name proxy) typename) - (return proxy))))) + (binding* ((proxy (gethash typename *cold-layouts*) :exit-if-null) + (layout (->wrapper (cold-layout-descriptor proxy)))) + (dotimes (i (cold-vector-len inherits)) + (when (descriptor= (cold-svref inherits i) layout) + (return t))))) +;;; Always return a WRAPPER if #+metaspace (define-cold-fop (fop-layout (depthoid flags length)) (decf depthoid) ; was bumped by 1 since non-stack args can't encode negatives (let* ((inherits (pop-stack)) @@ -2290,24 +2363,7 @@ (existing-layout (gethash name *cold-layouts*))) (declare (type descriptor bitmap-descriptor inherits)) (declare (type symbol name)) - (setq flags - ;; Nothing tests layout-flags at cross-compile time, - ;; so we can set them just-in-time for the cold core. - (logior flags - (cond ((member name '(pathname logical-pathname)) - sb-kernel:+pathname-layout-flag+) - ;; This layout flag would have to plumbed all the way through - ;; DEFSTRUCT-WITH-ALTERNATE-METACLASS and ENSURE-STRUCTURE-CLASS - ;; in order to set it for the root CONDITION type. - ((eq name 'condition) +condition-layout-flag+) - (t 0)))) - (flet ((maybe-set-flag (flag type) - (when (or (find-in-inherits type inherits) (eq name type)) - (setq flags (logior flags flag))))) - (maybe-set-flag +stream-layout-flag+ 'stream) - (maybe-set-flag +file-stream-layout-flag+ 'file-stream) - (maybe-set-flag +string-stream-layout-flag+ 'string-stream)) - ;; parameter have to match an existing FOP-LAYOUT invocation if there was one + ;; parameters have to match an existing FOP-LAYOUT invocation if there was one (when existing-layout (let ((old-flags (cold-layout-flags existing-layout)) (old-depthoid (cold-layout-depthoid existing-layout)) @@ -2325,13 +2381,16 @@ (return nil)))) ;; Users will never see this. (format t "old=(flags=~d depthoid=~d length=~d bitmap=~d inherits=~s)~%" - old-flags old-depthoid old-length old-bitmap old-inherits) + old-flags old-depthoid old-length old-bitmap + (vector-from-core old-inherits)) (format t "new=(flags=~d depthoid=~d length=~d bitmap=~d inherits=~s)~%" - flags depthoid length bitmap-value inherits) + flags depthoid length bitmap-value + (vector-from-core inherits)) (bug "Messed up fop-layout for ~s" name)))) - (if existing-layout - (cold-layout-descriptor existing-layout) - (make-cold-layout name depthoid flags length bitmap-value inherits)))) + (->wrapper + (if existing-layout + (cold-layout-descriptor existing-layout) + (make-cold-layout name depthoid flags length bitmap-value inherits))))) ;;;; cold fops for loading symbols @@ -2401,17 +2460,14 @@ (bug "CHARACTER-STRING[~D] dumped by cross-compiler." len)) (define-cold-fop (fop-vector (size)) - (if (zerop size) - *simple-vector-0-descriptor* - (let ((result (allocate-vector sb-vm:simple-vector-widetag - size size *dynamic*))) - (do ((index (1- size) (1- index))) - ((minusp index)) - (declare (fixnum index)) - (write-wordindexed result - (+ index sb-vm:vector-data-offset) - (pop-stack))) - (set-readonly result)))) + (do* ((stack (%fasl-input-stack (fasl-input))) + (stackptr (fop-stack-pop-n stack size) (1+ stackptr)) + (result (allocate-vector sb-vm:simple-vector-widetag + size size *dynamic*)) + (index sb-vm:vector-data-offset (1+ index)) + (end (+ sb-vm:vector-data-offset size))) + ((= index end) (set-readonly result)) + (write-wordindexed result index (svref stack stackptr)))) ; (not-cold-fop fop-array) ; the syntax doesn't work #+nil @@ -2446,42 +2502,23 @@ ;;;; cold fops for calling (or not calling) -(not-cold-fop fop-eval) -(not-cold-fop fop-eval-for-effect) - (defvar *load-time-value-counter*) (flet ((pop-args (argc fasl-input) (let ((args) (stack (%fasl-input-stack fasl-input))) (dotimes (i argc (values (pop-fop-stack stack) args)) - (push (pop-fop-stack stack) args)))) - (call (fun-name handler-name args) - (acond ((get fun-name handler-name) (apply it args)) - (t (error "Can't ~S ~S in cold load" handler-name fun-name))))) - + (push (pop-fop-stack stack) args))))) (define-cold-fop (fop-funcall (n)) (multiple-value-bind (fun args) (pop-args n (fasl-input)) (if args (case fun - (fdefinition - ;; Special form #'F fopcompiles into `(FDEFINITION ,f) - (aver (and (singleton-p args) (symbolp (car args)))) - (cold-symbol-function (car args))) - (cons (cold-cons (first args) (second args))) (symbol-global-value (cold-symbol-value (first args))) (values-specifier-type (let* ((des (first args)) (spec (if (descriptor-p des) (host-object-from-core des) des))) (ctype-to-core spec (funcall fun spec)))) - (sb-thread:make-mutex - (aver (eq (car args) :name)) - (write-slots (allocate-struct-of-type 'sb-thread:mutex) - 'sb-thread:mutex - :name (cadr args) - :%owner *nil-descriptor*)) - (t - (call fun :sb-cold-funcall-handler/for-value args))) + (t (error "Can't FOP-FUNCALL with function ~S in cold load." fun))) (let ((counter *load-time-value-counter*)) (push (cold-list (cold-intern :load-time-value) fun (number-to-core counter)) *!cold-toplevels*) @@ -2493,24 +2530,14 @@ (if (not args) (push fun *!cold-toplevels*) (case fun - (sb-impl::%defun (apply #'cold-fset args)) (sb-pcl::!trivial-defmethod (apply #'cold-defmethod args)) - (sb-kernel::%defstruct - (push args *known-structure-classoids*) - (push (apply #'cold-list (cold-intern 'defstruct) args) - *!cold-toplevels*)) - ((sb-c::%defconstant sb-impl::%defparameter) + ((sb-impl::%defconstant) (destructuring-bind (name val . rest) args (cold-set name (if (symbolp val) (cold-intern val) val)) (push (apply #'cold-list (cold-intern fun) (cold-intern name) rest) *!cold-defsymbols*))) - (set - (aver (= (length args) 2)) - (cold-set (first args) - (let ((val (second args))) - (if (symbolp val) (cold-intern val) val)))) - (%svset (apply 'cold-svset args)) - (t (call fun :sb-cold-funcall-handler/for-effect args))))))) + (t + (error "Can't FOP-FUNCALL-FOR-EFFECT with function ~S in cold load" fun))))))) ;;; Needed for certain L-T-V lambdas that use the -NO-SKIP variant of funcall. #-c-headers-only @@ -2576,7 +2603,8 @@ #-untagged-fdefns (write-wordindexed code index fdefn)) (define-cold-fop (fop-load-code (header code-size n-fixups)) - (let* ((n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) + (let* ((n-entries (read-unsigned-byte-32-arg (fasl-input-stream))) + (n-named-calls (read-unsigned-byte-32-arg (fasl-input-stream))) (immobile (oddp header)) ; decode the representation used by dump ;; The number of constants is rounded up to even (if required) ;; to ensure that the code vector will be properly aligned. @@ -2597,12 +2625,13 @@ (end (+ start code-size))) (read-bigvec-as-sequence-or-die (descriptor-mem des) (fasl-input-stream) :start start :end end) + (aver (= (code-n-entries des) n-entries)) (let ((jumptable-word (read-bits-wordindexed des aligned-n-boxed-words))) (aver (zerop (ash jumptable-word -14))) ;; assign serialno (write-wordindexed/raw des aligned-n-boxed-words - (logior (ash (incf *code-serialno*) (byte-position sb-vm::code-serialno-byte)) + (logior (ash (incf sb-c::*code-serialno*) (byte-position sb-vm::code-serialno-byte)) jumptable-word))) (when *show-pre-fixup-code-p* (format *trace-output* @@ -2616,17 +2645,39 @@ (* 2 sb-vm:n-word-bytes) (bvref-word (descriptor-mem des) i))))) - (let* ((fdefns-start (code-fdefns-start-index des)) - (fdefns-end (1- (+ fdefns-start n-named-calls)))) ; inclusive bound - (do ((index (1- n-boxed-words) (1- index))) - ((< index sb-vm:code-constants-offset)) - (let ((obj (pop-stack))) - (cond ((and (consp obj) (eq (car obj) :known-fun)) - (push (list* (cdr obj) des index) *deferred-known-fun-refs*)) - ((<= fdefns-start index fdefns-end) - (store-named-call-fdefn des index obj)) - (t - (write-wordindexed des index obj)))))) + (let* ((header-index sb-vm:code-constants-offset) + (stack (%fasl-input-stack (fasl-input))) + (n-constants (- n-boxed-words sb-vm:code-constants-offset)) + (stack-index (fop-stack-pop-n stack n-constants))) + (declare (type index header-index stack-index)) + (dotimes (fun-index (code-n-entries des)) + (let ((fn (%code-entry-point des fun-index))) + #+compact-instance-header + (write-wordindexed/raw fn 0 (logior (ash (cold-layout-descriptor-bits 'function) 32) + (read-bits-wordindexed fn 0))) + #+(or x86 x86-64) ; store a machine-native pointer to the function entry + ;; note that the bit pattern looks like fixnum due to alignment + (write-wordindexed/raw fn sb-vm:simple-fun-self-slot + (+ (- (descriptor-bits fn) sb-vm:fun-pointer-lowtag) + (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift))) + #-(or x86 x86-64) ; store a pointer back to the function itself in 'self' + (write-wordindexed fn sb-vm:simple-fun-self-slot fn)) + (dotimes (i sb-vm:code-slots-per-simple-fun) + (write-wordindexed des header-index (svref stack stack-index)) + (incf header-index) + (incf stack-index))) + (dotimes (i n-named-calls) + (store-named-call-fdefn des header-index (svref stack stack-index)) + (incf header-index) + (incf stack-index)) + (do () ((>= header-index n-boxed-words)) + (let ((constant (svref stack stack-index))) + (cond ((and (consp constant) (eq (car constant) :known-fun)) + (push (list* (cdr constant) des header-index) *deferred-known-fun-refs*)) + (t + (write-wordindexed des header-index constant)))) + (incf header-index) + (incf stack-index))) (apply-fixups (%fasl-input-stack (fasl-input)) des n-fixups))) @@ -2636,29 +2687,13 @@ (place (cdr item))) (write-wordindexed (car place) (cdr place) fun)))) -(defun compute-fun (code-object fun-index) - (let* ((code-instructions (calc-code-insts-address code-object)) - (fun (+ code-instructions (%code-fun-offset code-object fun-index)))) +(defun %code-entry-point (code-object fun-index) + (let ((fun (sap-int (sap+ (code-instructions code-object) + (%code-fun-offset code-object fun-index))))) (unless (zerop (logand fun sb-vm:lowtag-mask)) (error "unaligned function entry ~S ~S" code-object fun-index)) (make-descriptor (logior fun sb-vm:fun-pointer-lowtag)))) -(define-cold-fop (fop-fun-entry (fun-index)) - (let* ((code-object (pop-stack)) - (fn (compute-fun code-object fun-index))) - #+compact-instance-header - (write-wordindexed/raw - fn 0 (logior (descriptor-bits (cold-symbol-value 'sb-vm:function-layout)) - (read-bits-wordindexed fn 0))) - #+(or x86 x86-64) ; store a machine-native pointer to the function entry - ;; note that the bit pattern looks like fixnum due to alignment - (write-wordindexed/raw fn sb-vm:simple-fun-self-slot - (+ (- (descriptor-bits fn) sb-vm:fun-pointer-lowtag) - (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift))) - #-(or x86 x86-64) ; store a pointer back to the function itself in 'self' - (write-wordindexed fn sb-vm:simple-fun-self-slot fn) - fn)) - (define-cold-fop (fop-assembler-code) (aver (not *cold-assembler-obj*)) (let* ((length (read-word-arg (fasl-input-stream))) @@ -2669,7 +2704,7 @@ ;; Note: we round the number of constants up to ensure that ;; the code vector will be properly aligned. (round-up sb-vm:code-constants-offset 2)) - (space (or #+immobile-space *immobile-varyobj* + (space (or #+(and immobile-code (not metaspace)) *immobile-varyobj* ;; If there is a read-only space, use it, else use static space. (if (> sb-vm:read-only-space-end sb-vm:read-only-space-start) *read-only* @@ -2708,6 +2743,11 @@ ;;; Target variant of this is defined in 'target-load' (defun apply-fixups (fop-stack code-obj n-fixups) + (let ((alloc-points (pop-fop-stack fop-stack))) + (when alloc-points + (cold-set 'sb-c::*!cold-allocation-patch-point* + (cold-cons (cold-cons code-obj alloc-points) + (cold-symbol-value 'sb-c::*!cold-allocation-patch-point*))))) (dotimes (i n-fixups code-obj) (binding* ((info (descriptor-fixnum (pop-fop-stack fop-stack))) (sym (pop-fop-stack fop-stack)) @@ -2729,8 +2769,11 @@ #+sb-thread ; ENSURE-SYMBOL-TLS-INDEX isn't defined otherwise (:symbol-tls-index (ensure-symbol-tls-index sym)) (:layout (cold-layout-descriptor-bits sym)) - (:layout-id (cold-layout-id (gethash (descriptor-bits sym) - *cold-layout-by-addr*))) + (:layout-id ; SYM is a # + (cold-layout-id (gethash (descriptor-bits (->layout sym)) + *cold-layout-by-addr*))) + ;; The machine-dependent code decides how to patch in 'nbits' + #+gencgc (:gc-barrier sb-vm::gencgc-card-table-index-nbits) (:immobile-symbol ;; an interned symbol is represented by its host symbol, ;; but an uninterned symbol is a descriptor. @@ -2740,13 +2783,7 @@ (:named-call (+ (descriptor-bits (cold-fdefinition-object sym)) (- 2 sb-vm:other-pointer-lowtag)))) - kind flavor)) - (when (and (member sym '(sb-vm::enable-alloc-counter - sb-vm::enable-sized-alloc-counter)) - ;; Ignore symbol fixups naming these assembly routines! - (member flavor '(:assembly-routine :assembly-routine*))) - (push (cold-cons code-obj (make-fixnum-descriptor offset)) - *allocation-point-fixup-notes*))))) + kind flavor))))) ;;;; sanity checking space layouts @@ -2822,6 +2859,8 @@ (format t "#define LISP_FEATURE_~A~%" target-feature-name)) (terpri) ;; and miscellaneous constants + (format t "#define SBCL_TARGET_ARCHITECTURE_STRING ~S~%" + (substitute #\_ #\- (string-downcase (sb-cold::target-platform-keyword)))) (format t "#define SBCL_VERSION_STRING ~S~%" (sb-xc:lisp-implementation-version)) (format t "#define CORE_MAGIC 0x~X~%" core-magic) @@ -2909,8 +2948,11 @@ sb-vm:n-lowtag-bits sb-vm:lowtag-mask sb-vm:n-widetag-bits sb-vm:widetag-mask sb-vm:n-fixnum-tag-bits sb-vm:fixnum-tag-mask + sb-vm:instance-length-mask sb-vm:dsd-raw-type-mask - sb-vm:short-header-max-words)) + sb-vm:short-header-max-words + sb-vm:array-flags-position + sb-vm:array-rank-position)) (push (list (c-symbol-name c) -1 ; invent a new priority (symbol-value c) @@ -2969,6 +3011,10 @@ (terpri) + #+(and win32 x86-64) + (format t "#define WIN64_SEH_DATA_ADDR ((void*)~DUL) /* ~:*0x~X */~%" + sb-vm:win64-seh-data-addr) + ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between ;; platforms. If we export this from the SB-VM package, it gets ;; written out as #define trap_PseudoAtomic, which is confusing as @@ -3047,6 +3093,9 @@ (format stream "#define INTERNAL_ERROR_NARGS {~{~S~^, ~}}~2%" (map 'list #'cddr sb-c:+backend-internal-errors+))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (import 'sb-vm::primitive-object-variable-length-p)) + (defun write-tagnames-h (out) (labels ((pretty-name (symbol strip) @@ -3076,16 +3125,16 @@ ;; this -2 shift depends on every OTHER-IMMEDIATE-?-LOWTAG ;; ending with the same 2 bits. (#b10) (write-tags "" "-WIDETAG" (ash (1+ sb-vm:widetag-mask) -2) -2)) - (dolist (prim-obj '(symbol ratio complex sb-vm::code simple-fun - closure funcallable-instance - weak-pointer fdefn sb-vm::value-cell)) + (dolist (name '(symbol ratio complex sb-vm::code simple-fun + closure funcallable-instance + weak-pointer fdefn sb-vm::value-cell)) (format out "static char *~A_slots[] = {~%~{ \"~A: \",~} NULL~%};~%" - (c-name (string-downcase prim-obj)) - (mapcar (lambda (x) (c-name (string-downcase (sb-vm:slot-name x)))) - (remove-if 'sb-vm:slot-rest-p - (sb-vm:primitive-object-slots - (find prim-obj sb-vm:*primitive-objects* - :key 'sb-vm:primitive-object-name)))))) + (c-name (string-downcase name)) + (map 'list (lambda (x) (c-name (string-downcase (sb-vm:slot-name x)))) + (let* ((obj (sb-vm::primitive-object name)) + (slots (coerce (sb-vm:primitive-object-slots obj) 'list))) + (butlast slots + (if (primitive-object-variable-length-p obj) 1 0)))))) (values)) (defun write-c-print-dispatch (out) @@ -3102,9 +3151,16 @@ (format out "static void (*~a_fns[])(lispobj obj) = {~ ~{~% ~a, ~a, ~a, ~a~^,~}~%};~%" flavor (coerce a 'list))))) -(defun write-cast-operator (name c-name lowtag) - (format t "static inline struct ~A* ~A(lispobj obj) { - return (struct ~A*)(obj - ~D);~%}~%" c-name name c-name lowtag)) +(defun write-cast-operator (operator-name c-name lowtag stream) + (format stream "static inline struct ~A* ~A(lispobj obj) { + return (struct ~A*)(obj - ~D);~%}~%" c-name operator-name c-name lowtag)) + +(defun mangle-c-slot-name (obj-name slot-name) + ;; For data hiding purposes, change the name of vector->length to vector->length_. + ;; This helped me catch some erroneous C code. + (if (and (eq obj-name 'vector) (eq slot-name 'length)) + "length_" + (c-name (string-downcase slot-name)))) (defun write-primitive-object (obj *standard-output*) (let* ((name (sb-vm:primitive-object-name obj)) @@ -3113,34 +3169,46 @@ (lowtag (or (symbol-value (sb-vm:primitive-object-lowtag obj)) 0))) ;; writing primitive object layouts (flet ((output-c () - (when (eq name 'sb-vm::thread) - (format t "#define THREAD_HEADER_SLOTS ~d~%" sb-vm::thread-header-slots) - (dolist (x sb-vm::*thread-header-slot-names*) - (let ((s (package-symbolicate "SB-VM" "THREAD-" x "-SLOT"))) - (format t "#define ~a ~d~%" - (c-name (string s)) (symbol-value s)))) - (terpri)) + (when (eq name 'sb-vm::code) + (format t "#define CODE_SLOTS_PER_SIMPLE_FUN ~d~2%" + sb-vm:code-slots-per-simple-fun)) (format t "struct ~A {~%" c-name) (when (sb-vm:primitive-object-widetag obj) (format t " lispobj header;~%")) - (dolist (slot slots) + (dovector (slot slots) (format t " ~A ~A~@[[1]~];~%" - (getf (sb-vm:slot-options slot) :c-type "lispobj") - (c-name (string-downcase (sb-vm:slot-name slot))) - (sb-vm:slot-rest-p slot))) + (getf (cddr slot) :c-type "lispobj") + (mangle-c-slot-name name (sb-vm:slot-name slot)) + (and (primitive-object-variable-length-p obj) + (eq slot (aref slots (1- (length slots))))))) (format t "};~%") - (when (member name '(cons vector symbol fdefn)) - (write-cast-operator name c-name lowtag))) + (when (eq name 'vector) + ;; This is 'sword_t' because we formerly would call fixnum_value() which + ;; is a signed int, but it isn't really; except that I made all C vars + ;; signed to avoid comparison mismatch, and don't want to change back. + (format t "static inline sword_t vector_len(struct vector* v) {") + #+ubsan (format t " return v->header >> ~d; }~%" + (+ 32 sb-vm:n-fixnum-tag-bits)) + #-ubsan (format t " return v->length_ >> ~d; }~%" + sb-vm:n-fixnum-tag-bits)) + (when (member name '(cons vector symbol fdefn instance)) + (write-cast-operator name c-name lowtag *standard-output*))) (output-asm () (format t "/* These offsets are SLOT-OFFSET * N-WORD-BYTES - LOWTAG~%") (format t " * so they work directly on tagged addresses. */~2%") - (dolist (slot slots) + (dovector (slot slots) (format t "#define ~A_~A_OFFSET ~D~%" (c-symbol-name name) (c-symbol-name (sb-vm:slot-name slot)) (- (* (sb-vm:slot-offset slot) sb-vm:n-word-bytes) lowtag))) (format t "#define ~A_SIZE ~d~%" (string-upcase c-name) (sb-vm:primitive-object-length obj)))) + (when (eq name 'sb-vm::thread) + (format t "#define THREAD_HEADER_SLOTS ~d~%" sb-vm::thread-header-slots) + (dolist (x sb-vm::*thread-header-slot-names*) + (let ((s (package-symbolicate "SB-VM" "THREAD-" x "-SLOT"))) + (format t "#define ~a ~d~%" (c-name (string s)) (symbol-value s)))) + (terpri)) (format t "#ifdef __ASSEMBLER__~2%") (output-asm) (format t "~%#else /* __ASSEMBLER__ */~2%") @@ -3176,9 +3244,6 @@ (if (string= (car slot) "default") "_default" (car slot)) (cdr slot)))) (format t "};~%") - (when (member (dd-name dd) '(layout)) - (write-cast-operator (dd-name dd) (cstring (dd-name dd)) - sb-vm:instance-pointer-lowtag)) (format t "~%#endif /* __ASSEMBLER__ */~2%"))) (defun write-thread-init (stream) @@ -3210,10 +3275,12 @@ (format stream "#define ~A_tlsindex 0x~X~%" c-symbol (ensure-symbol-tls-index symbol)))) ;; This #define is relative to the start of the fixedobj space to allow heap relocation. - #+immobile-space - (format stream "~@{#define LAYOUT_OF_~A (lispobj)(FIXEDOBJ_SPACE_START+0x~x)~%~}" - "FUNCTION" (- (cold-layout-descriptor-bits 'function) - (gspace-byte-address *immobile-fixedobj*))) + #+(or immobile-space metaspace) + (format stream "~@{#define LAYOUT_OF_~A (lispobj)(~A_SPACE_START+0x~x)~%~}" + "FUNCTION" + #+metaspace "READ_ONLY" #-metaspace "FIXEDOBJ" + (- (cold-layout-descriptor-bits 'function) + (gspace-byte-address (symbol-value *cold-layout-gspace*)))) ;; For immobile code, define a constant for the address of the vector of ;; C-callable fdefns, and then fdefns in terms of indices to that vector. #+immobile-code @@ -3280,11 +3347,13 @@ "layouts" "type specifiers" "symbols" - "linkage table"))) + "linkage table" + #+sb-thread "TLS map"))) (dotimes (i (length sections)) (format t "~4<~@R~>. ~A~%" (1+ i) (nth i sections)))) (format t "=================~2%") - (format t "I. assembler routines defined in core image:~2%") + (format t "I. assembler routines defined in core image: (base=~x)~2%" + (descriptor-bits *cold-assembler-obj*)) (dolist (routine *cold-assembler-routines*) (let ((name (car routine))) (format t "~8,'0X: ~S~%" (lookup-assembler-reference name) name))) @@ -3336,23 +3405,37 @@ CELL CLASSOID NAME ========== ========== ====~%") - (dolist (x (sort (%hash-table-alist *classoid-cells*) #'string< :key #'car)) - (destructuring-bind (name . cell) x - (format t "~10,'0x ~:[ ~;~:*~10,'0X~] ~S~%" - (descriptor-bits cell) - (let ((classoid - (read-slot cell (find-layout 'sb-kernel::classoid-cell) :classoid))) - (unless (cold-null classoid) (descriptor-bits classoid))) - name))) + (let ((dumped-classoids)) + (dolist (x (sort (%hash-table-alist *classoid-cells*) #'string< :key #'car)) + (destructuring-bind (name . cell) x + (format t "~10,'0x ~:[ ~;~:*~10,'0X~] ~S~%" + (descriptor-bits cell) + (let ((classoid (read-slot cell :classoid))) + (unless (cold-null classoid) + (push classoid dumped-classoids) + (descriptor-bits classoid))) + name))) + ;; Something goes wrong when dumping classoids, so show the memory + (terpri) + (dolist (classoid dumped-classoids) + (let ((nwords (logand (ash (read-bits-wordindexed classoid 0) + (- sb-vm:instance-length-shift)) + sb-vm:instance-length-mask))) + (format t "Classoid @ ~x, ~d words:~%" (descriptor-bits classoid) (1+ nwords)) + (dotimes (i (1+ nwords)) ; include the header word in output + (format t "~2d: ~10x~%" i (read-bits-wordindexed classoid i))) + (terpri)))) (format t "~%~|~%V. layout names:~2%") - (format t " Bitmap Depth ID Name [Length]~%") + (format t "~28tBitmap Depth ID Name [Length]~%") (dolist (pair (sort-cold-layouts)) (let* ((proxy (cdr pair)) (descriptor (cold-layout-descriptor proxy)) (addr (descriptor-bits descriptor))) - (format t "~10,'0X: ~8d ~2D ~5D ~S [~D]~%" + (format t "~10,'0X -> ~10,'0X: ~8d ~2D ~5D ~S [~D]~%" addr + #+metaspace (descriptor-bits (->wrapper descriptor)) + #-metaspace " " (cold-layout-bitmap proxy) (cold-layout-depthoid proxy) (cold-layout-id proxy) @@ -3365,7 +3448,7 @@ (format t "~X: [~vx] ~S~%" (descriptor-bits (cdr cell)) (* 2 sb-vm:n-word-bytes) - (read-slot (cdr cell) 'sb-kernel:ctype :%bits) + (read-slot (cdr cell) :%bits) (car cell))) (sort (%hash-table-alist *ctype-cache*) #'< :key (lambda (x) (descriptor-bits (cdr x)))))) @@ -3384,6 +3467,10 @@ (sb-vm::linkage-table-entry-address (cdr entry)) (car (ensure-list name)))))) + #+sb-thread + (format t "~%~|~%IV. TLS map:~2%~:{~4x ~s~%~}" + (sort *tls-index-to-symbol* #'< :key #'car)) + (values)) ;;;; writing core file @@ -3391,7 +3478,12 @@ (defun output-gspace (gspace data-page core-file write-word verbose) (force-output core-file) (let* ((posn (file-position core-file)) - (bytes (* (gspace-free-word-index gspace) sb-vm:n-word-bytes)) + (bytes (cond + #+metaspace + ((eq (gspace-identifier gspace) read-only-core-space-id) + (- sb-vm:read-only-space-end sb-vm:read-only-space-start)) + (t + (* (gspace-free-word-index gspace) sb-vm:n-word-bytes)))) (pages (ceiling bytes sb-c:+backend-page-bytes+)) (total-bytes (* pages sb-c:+backend-page-bytes+))) @@ -3471,14 +3563,16 @@ (write-bigvec-as-sequence ptes core-file :end pte-bytes) (force-output core-file) (file-position core-file posn)) - (mapc write-word ; 5 = number of words in this core header entry - `(,page-table-core-entry-type-code 5 ,n-ptes ,pte-bytes ,data-page)))) + (mapc write-word + `(,page-table-core-entry-type-code + 6 ; = number of words in this core header entry + ,sb-vm::gencgc-card-table-index-nbits ,n-ptes ,pte-bytes ,data-page)))) ;;; Create a core file created from the cold loaded image. (This is ;;; the "initial core file" because core files could be created later ;;; by executing SAVE-LISP in a running system, perhaps after we've ;;; added some functionality to the system.) -(defun write-initial-core-file (filename verbose) +(defun write-initial-core-file (filename build-id verbose) (when verbose (let ((*print-length* nil) @@ -3503,7 +3597,8 @@ ;; plus a suffix identifying a certain configuration of the C compiler. (binding* ((build-id (concatenate 'string - (with-open-file (s "output/build-id.inc") (read s)) + (or build-id + (with-open-file (s "output/build-id.inc") (read s))) (if (member :msan sb-xc:*features*) "-msan" ""))) ((nwords padding) (ceiling (length build-id) sb-vm:n-word-bytes))) (declare (type simple-string build-id)) @@ -3512,7 +3607,7 @@ (write-word build-id-core-entry-type-code) (write-word (+ 3 nwords)) ; 3 = fixed overhead including this word (write-word (length build-id)) - (dovector (char build-id) (write-byte (sb-xc:char-code char) core-file)) + (dovector (char build-id) (write-byte (char-code char) core-file)) (dotimes (j (- padding)) (write-byte #xff core-file))) ;; Write the Directory entry header. @@ -3566,6 +3661,7 @@ ;;; MAP-FILE-NAME gets the name of the textual 'cold-sbcl.map' file (defun sb-cold:genesis (&key object-file-names tls-init defstruct-descriptions + build-id core-file-name c-header-dir-name map-file-name symbol-table-file-name (verbose t)) (declare (ignorable symbol-table-file-name)) @@ -3586,11 +3682,6 @@ ;; Prefill some linkage table entries perhaps (loop for (name datap) in sb-vm::*linkage-space-predefined-entries* do (linkage-table-note-symbol name datap)) - #-(or linkage-table crossbuild-test) - (when core-file-name - (if symbol-table-file-name - (load-cold-foreign-symbol-table symbol-table-file-name) - (error "can't output a core file without symbol table file input"))) ;; Now that we've successfully read our only input file (by ;; loading the symbol table, if any), it's a good time to ensure @@ -3636,14 +3727,12 @@ (*nil-descriptor*) (*simple-vector-0-descriptor*) (*c-callable-fdefn-vector*) - (*known-structure-classoids* nil) - (*layout-deferred-instances* (make-hash-table :test 'eq)) (*classoid-cells* (make-hash-table :test 'eq)) (*ctype-cache* (make-hash-table :test 'equal)) (*cold-layouts* (make-hash-table :test 'eq)) ; symbol -> cold-layout (*cold-layout-by-addr* (make-hash-table :test 'eql)) ; addr -> cold-layout (*!cold-defsymbols* nil) - (*!cold-defuns* nil) + (*tls-index-to-symbol* nil) ;; '*COLD-METHODS* is never seen in the target, so does not need ;; to adhere to the #\! convention for automatic uninterning. (*cold-methods* nil) @@ -3653,18 +3742,19 @@ *cold-assembler-obj* *deferred-undefined-tramp-refs* (*code-fixup-notes* (make-hash-table)) - (*allocation-point-fixup-notes* nil) (*deferred-known-fun-refs* nil)) (setf *nil-descriptor* (make-nil-descriptor) *simple-vector-0-descriptor* (vector-in-core nil)) + (when core-file-name + (read-structure-definitions defstruct-descriptions)) ;; Prepare for cold load. (initialize-layouts) (when core-file-name - (read-structure-definitions defstruct-descriptions) (initialize-packages)) (initialize-static-space tls-init) + (cold-set 'sb-c::*!cold-allocation-patch-point* *nil-descriptor*) ;; Load all assembler code (flet ((assembler-file-p (name) (tailwise-equal (namestring name) ".assem-obj"))) @@ -3696,7 +3786,7 @@ ;; target of accidental leftover symbols, not that it wouldn't also be ;; a good idea to clean up package-data-list once in a while. (dolist (exported-name - (sb-cold:read-from-file "common-lisp-exports.lisp-expr")) + (sb-cold:read-from-file "^common-lisp-exports.lisp-expr")) (cold-intern (intern exported-name *cl-package*) :access :external)) ;; Make LOGICALLY-READONLYIZE no longer a no-op @@ -3705,28 +3795,18 @@ ;; Cold load. (dolist (file-name object-file-names) + (push (cold-cons :begin-file (base-string-to-core file-name)) *!cold-toplevels*) (cold-load file-name verbose)) (sb-cold::check-no-new-cl-symbols) - (when *known-structure-classoids* - (let ((dd-layout (find-layout 'defstruct-description))) - (dolist (defstruct-args *known-structure-classoids*) - (let* ((dd (first defstruct-args)) - (name (warm-symbol (read-slot dd dd-layout :name))) - (layout (gethash name *cold-layouts*))) - (aver layout) - (write-slots (cold-layout-descriptor layout) *host-layout-of-layout* - :%info dd)))) - (when verbose - (format t "~&; SB-Loader: (~D~@{+~D~}) structs/vars/funs/methods/other~%" - (length *known-structure-classoids*) - (length *!cold-defsymbols*) - (length *!cold-defuns*) - (reduce #'+ *cold-methods* :key (lambda (x) (length (cdr x)))) - (length *!cold-toplevels*)))) + (when (and verbose core-file-name) + (format t "~&; SB-Loader: (~D~@{+~D~}) vars/methods/other~%" + (length *!cold-defsymbols*) + (reduce #'+ *cold-methods* :key (lambda (x) (length (cdr x)))) + (length *!cold-toplevels*))) - (dolist (symbol '(*!cold-defsymbols* *!cold-defuns* *!cold-toplevels*)) + (dolist (symbol '(*!cold-defsymbols* *!cold-toplevels*)) (cold-set symbol (list-to-core (nreverse (symbol-value symbol)))) (makunbound symbol)) ; so no further PUSHes can be done @@ -3753,7 +3833,11 @@ (list (cold-intern (and (null qual) (predicate-for-specializer class))) (cold-intern qual) - (cold-intern class) + (acond ((gethash class *cold-layouts*) + (->wrapper (cold-layout-descriptor it))) + (t + (aver (predicate-for-specializer class)) + (cold-intern class))) fun lambda-list source-loc)))))))) @@ -3761,12 +3845,9 @@ (resolve-deferred-known-funs) (resolve-static-call-fixups) (foreign-symbols-to-core) - #+(or x86 immobile-space) (dolist (pair (sort (%hash-table-alist *code-fixup-notes*) #'< :key #'car)) (write-wordindexed (make-random-descriptor (car pair)) sb-vm::code-fixups-slot (repack-fixups (cdr pair)))) - (cold-set 'sb-c::*!cold-allocation-point-fixups* - (vector-in-core *allocation-point-fixup-notes*)) (when core-file-name (finish-symbols)) (finalize-load-time-value-noise) @@ -3797,7 +3878,7 @@ (with-open-file (stream map-file-name :direction :output :if-exists :supersede) (write-map stream))) (when core-file-name - (write-initial-core-file core-file-name verbose)) + (write-initial-core-file core-file-name build-id verbose)) (unless c-header-dir-name (return-from sb-cold:genesis)) (let ((filename (format nil "~A/Makefile.features" c-header-dir-name))) @@ -3854,14 +3935,26 @@ (dolist (obj structs) (format stream "~&#include \"~A.h\"~%" (string-downcase (sb-vm:primitive-object-name obj)))))) + (out-to "layout" + #-metaspace + (write-structure-object (wrapper-info (find-layout 'wrapper)) stream + "layout") + #+metaspace + (progn + (write-structure-object (wrapper-info (find-layout 'sb-vm:layout)) stream) + (write-structure-object (wrapper-info (find-layout 'wrapper)) stream) + (write-cast-operator 'wrapper "wrapper" sb-vm:instance-pointer-lowtag stream)) + (write-cast-operator 'layout "layout" sb-vm:instance-pointer-lowtag stream)) (dolist (class '(defstruct-description defstruct-slot-description - classoid layout hash-table package + classoid + hash-table package sb-thread::avlnode sb-thread::mutex sb-c::compiled-debug-info sb-c::compiled-debug-fun)) (out-to (string-downcase class) - (write-structure-object (layout-info (find-layout class)) stream))) + (write-structure-object (wrapper-info (find-layout class)) + stream))) (out-to "thread-instance" - (write-structure-object (layout-info (find-layout 'sb-thread::thread)) + (write-structure-object (wrapper-info (find-layout 'sb-thread::thread)) stream "thread_instance")) (with-open-file (stream (format nil "~A/thread-init.inc" c-header-dir-name) :direction :output :if-exists :supersede) @@ -3874,6 +3967,8 @@ ;;; then we can produce a host object even if it is not a faithful rendition. (defun host-object-from-core (descriptor &optional (strictp t)) (named-let recurse ((x descriptor)) + (when (symbolp x) + (return-from recurse x)) (when (cold-null x) (return-from recurse nil)) (when (is-fixnum-lowtag (descriptor-lowtag x)) @@ -3912,3 +4007,11 @@ (#.sb-vm:double-float-widetag (double-float-from-core x)) (#.sb-vm:bignum-widetag (bignum-from-core x)))))))) + +(defun read-n-bytes (stream vector start end) + (aver (zerop start)) + (let* ((start (+ (descriptor-byte-offset vector) + (ash sb-vm:vector-data-offset sb-vm:word-shift))) + (end (+ start end))) + (read-bigvec-as-sequence-or-die (descriptor-mem vector) + stream :start start :end end))) diff -Nru sbcl-2.1.1/src/compiler/generic/interr.lisp sbcl-2.1.11/src/compiler/generic/interr.lisp --- sbcl-2.1.1/src/compiler/generic/interr.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/interr.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -55,8 +55,9 @@ (type-specifier (specifier-type `(simple-array ,(sb-vm:saetp-specifier saetp) (*))))) - (remove t sb-vm:*specialized-array-element-type-properties* - :key 'sb-vm:saetp-specifier)))) + (remove-if (lambda (x) (member x '(nil t))) + sb-vm:*specialized-array-element-type-properties* + :key 'sb-vm:saetp-specifier)))) `(((integer 0 ,array-dimension-limit) object-not-array-dimension) ;; Union of all unboxed array specializations, @@ -109,6 +110,8 @@ ("odd number of &KEY arguments" odd-key-args 0) ("unknown &KEY argument" unknown-key-arg 1) ("invalid array index" invalid-array-index 3) + ("invalid vector index" invalid-vector-index 2) + ("uninitialized element" uninitialized-element 2) ("A function with declared result type NIL returned." nil-fun-returned 1) ("An array with element-type NIL was accessed." nil-array-accessed 1) ("Object layout is invalid. (indicates obsolete instance)" layout-invalid 2) @@ -185,7 +188,7 @@ sb-c::vop sb-c::basic-combination sb-sys:fd-stream - layout + wrapper (sb-assem:segment object-not-assem-segment) sb-c::cblock sb-disassem:disassem-state @@ -231,20 +234,3 @@ (if (array-in-bounds-p sb-c:+backend-internal-errors+ error-number) (cddr (svref sb-c:+backend-internal-errors+ error-number)) 0)) - -#-sb-xc-host ; no SB-C:SAP-READ-VAR-INTEGERF -(defun decode-internal-error-args (sap trap-number &optional error-number) - (let ((error-number (cond (error-number) - ((>= trap-number sb-vm:error-trap) - (prog1 - (- trap-number sb-vm:error-trap) - (setf trap-number sb-vm:error-trap))) - (t - (prog1 (sap-ref-8 sap 0) - (setf sap (sap+ sap 1))))))) - (let ((length (sb-kernel::error-length error-number))) - (declare (type (unsigned-byte 8) length)) - (values error-number - (loop repeat length with index = 0 - collect (sb-c:sap-read-var-integerf sap index)) - trap-number)))) diff -Nru sbcl-2.1.1/src/compiler/generic/late-objdef.lisp sbcl-2.1.11/src/compiler/generic/late-objdef.lisp --- sbcl-2.1.1/src/compiler/generic/late-objdef.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/late-objdef.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -23,17 +23,19 @@ (defconstant extended-symbol-size (1+ symbol-size)) #+sb-thread -(dolist (slot (primitive-object-slots - (find 'thread *primitive-objects* :key #'primitive-object-name))) +(dovector (slot (primitive-object-slots (primitive-object 'thread))) (when (slot-special slot) (setf (info :variable :wired-tls (slot-special slot)) (ash (slot-offset slot) word-shift)))) #+gencgc -(defconstant large-object-size - (* 4 (max +backend-page-bytes+ gencgc-card-bytes - gencgc-alloc-granularity))) - +(progn +;;; don't change allocation granularity +(assert (= gencgc-alloc-granularity 0)) +;;; cards are not larger than pages +(assert (<= gencgc-card-bytes +backend-page-bytes+)) +;;; largeness does not depend on the hardware page size +(defconstant large-object-size (* 4 gencgc-card-bytes))) ;;; Keep this (mostly) lined up with 'early-objdef' for sanity's sake! #+sb-xc-host @@ -42,7 +44,7 @@ (lambda (entry) (cons (symbol-value (symbolicate (car entry) "-WIDETAG")) (cdr entry))) - `((bignum "unboxed" "bignum" "bignum") + `((bignum "bignum") (ratio "boxed" "ratio_or_complex" "boxed") (single-float ,(or #+64-bit "immediate" "unboxed")) (double-float "unboxed") @@ -65,7 +67,7 @@ ;; Like closure, but these can also have a layout pointer in the high header bytes. (funcallable-instance "funinstance" "lose" "short_boxed") ;; These have a scav and trans function, but no size function. - #-(or x86 x86-64) (return-pc "return_pc_header" "return_pc_header" "lose") + #-(or x86 x86-64 arm64) (return-pc "return_pc_header" "return_pc_header" "lose") (value-cell "boxed") (symbol "tiny_boxed") @@ -111,11 +113,13 @@ (simple-array-complex-double-float "vector_unsigned_byte_128") (simple-bit-vector "vector_bit") - (simple-vector "vector") + (simple-vector "vector_t") (simple-array-nil "vector_nil") (simple-base-string "base_string") - #+sb-unicode (simple-character-string "character_string") + ;; UB32 works fine for character string, unless we decide to reimplement + ;; using 3 octets per code point. + #+sb-unicode (simple-character-string "vector_unsigned_byte_32") #+sb-unicode (complex-character-string "array") (complex-base-string "array") @@ -139,7 +143,7 @@ min (ldb (byte 32 32) bits)) ;; Union in the bits for other unboxed object types. (dolist (entry *scav/trans/size*) - (when (string= (second entry) "unboxed") + (when (member (second entry) '("bignum" "unboxed") :test 'string=) (setf bits (logior bits (ash 1 (ash (car entry) -2)))))) (format stream "static inline int leaf_obj_widetag_p(unsigned char widetag) {~%") #+64-bit (format stream " return (0x~XLU >> (widetag>>2)) & 1;" bits) diff -Nru sbcl-2.1.1/src/compiler/generic/late-type-vops.lisp sbcl-2.1.11/src/compiler/generic/late-type-vops.lisp --- sbcl-2.1.1/src/compiler/generic/late-type-vops.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/late-type-vops.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,270 +0,0 @@ -;;;; generic type testing and checking VOPs - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. -(in-package "SB-VM") - - -;;; FIXME: backend-specific junk doesn't belong in compiler/generic. - -#+(or x86 x86-64) -(progn -(define-vop (type-predicate) - (:args (value :scs (any-reg descriptor-reg))) - ;; x86 code has to avoid 'esi' and 'edi' for the temp - ;; since they can't be accessed as an 8-bit byte. - ;; x86-64 being more regular, any reg can serve as the temp. - ;; In all likelihood, it'll get rax anyway just because. - (:temporary (:sc unsigned-reg #+x86 :offset #+x86 eax-offset) temp) - (:conditional) - (:info target not-p) - (:args-var args) - (:policy :fast-safe)) -(define-vop (simple-type-predicate) - (:args (value :scs (any-reg descriptor-reg control-stack))) - (:conditional) - (:info target not-p) - (:args-var args) - (:policy :fast-safe)) -;; A vop that accepts a computed set of widetags. -(define-vop (%other-pointer-subtype-p type-predicate) - (:translate %other-pointer-subtype-p) - (:info target not-p widetags) - (:arg-types * (:constant t)) ; voodoo - 'target' and 'not-p' are absent - (:generator 15 ; arbitrary - (multiple-value-bind (headers except) (canonicalize-widetags+exceptions widetags) - (%test-headers value temp target not-p nil headers :except except - :value-tn-ref args))))) - -#-(or x86 x86-64) -(progn -(define-vop (type-predicate) - (:args (value :scs (any-reg descriptor-reg))) - (:temporary (:sc non-descriptor-reg) temp) - (:conditional) - (:info target not-p) - (:args-var args) - (:policy :fast-safe)) -;; A vop that accepts a computed set of widetags. -(define-vop (%other-pointer-subtype-p type-predicate) - (:translate %other-pointer-subtype-p) - (:info target not-p widetags) - (:arg-types * (:constant t)) ; voodoo - 'target' and 'not-p' are absent - (:args-var args) - (:generator 15 ; arbitrary - (%test-headers value temp target not-p nil (canonicalize-widetags widetags) - :value-tn-ref args)))) - -(defmacro define-type-vop (pred-name type-codes - &optional (inherit 'type-predicate)) - (let ((cost (if (> (reduce #'max type-codes :key #'eval) lowtag-limit) - 7 - 4))) - `(define-vop (,pred-name ,inherit) - (:translate ,pred-name) - (:generator ,cost - (test-type value - ,(if (eq inherit 'simple-type-predicate) nil 'temp) - target not-p ,type-codes - :value-tn-ref args))))) - -#-x86-64 ; defined in compiler/x86-64/type-vops for x86-64 -(define-type-vop fixnump - #.fixnum-lowtags - #+(or x86) simple-type-predicate) ;; save a register - -(define-type-vop functionp (fun-pointer-lowtag)) - -(define-type-vop listp (list-pointer-lowtag)) - -(define-type-vop non-null-symbol-p (symbol-widetag)) - -(define-type-vop %instancep (instance-pointer-lowtag)) - -(define-type-vop %other-pointer-p (other-pointer-lowtag)) - -(define-type-vop bignump (bignum-widetag)) - -(define-type-vop ratiop (ratio-widetag)) - -(define-type-vop complexp - (complex-widetag complex-single-float-widetag complex-double-float-widetag - #+long-float complex-long-float-widetag)) - -(define-type-vop complex-rational-p (complex-widetag)) - -(define-type-vop complex-float-p - (complex-single-float-widetag complex-double-float-widetag - #+long-float complex-long-float-widetag)) - -(define-type-vop complex-single-float-p (complex-single-float-widetag)) - -(define-type-vop complex-double-float-p (complex-double-float-widetag)) - -(define-type-vop single-float-p (single-float-widetag) - #+x86-64 simple-type-predicate) - -(define-type-vop double-float-p (double-float-widetag)) - -(define-type-vop simple-string-p - (#+sb-unicode simple-character-string-widetag - simple-base-string-widetag)) - -(macrolet - ((define-simple-array-type-vops () - `(progn - ,@(map 'list - (lambda (saetp) - (let ((primtype (saetp-primitive-type-name saetp))) - `(define-type-vop - ,(symbolicate primtype "-P") - (,(saetp-typecode saetp))))) - *specialized-array-element-type-properties*)))) - (define-simple-array-type-vops)) - -(macrolet - ((def () - `(define-type-vop simple-rank-1-array-*-p - ,(map 'list #'saetp-typecode - *specialized-array-element-type-properties*)))) - (def)) ; simple-rank-1-array-*-p - -(define-type-vop characterp (character-widetag) - #+x86-64 simple-type-predicate) - -(define-type-vop system-area-pointer-p (sap-widetag)) - -(define-type-vop weak-pointer-p (weak-pointer-widetag)) - -(define-type-vop code-component-p (code-header-widetag)) - -#-(or x86 x86-64) (define-type-vop lra-p (return-pc-widetag)) - -(define-type-vop fdefn-p (fdefn-widetag)) - -(define-type-vop closurep (closure-widetag)) - -(define-type-vop simple-fun-p (simple-fun-widetag)) - -(define-type-vop funcallable-instance-p (funcallable-instance-widetag)) - -(define-type-vop array-header-p - (simple-array-widetag - #+sb-unicode complex-character-string-widetag - complex-base-string-widetag complex-bit-vector-widetag - complex-vector-widetag complex-array-widetag)) - -(define-type-vop simple-array-header-p - (simple-array-widetag)) - -(define-type-vop stringp - (#+sb-unicode simple-character-string-widetag - #+sb-unicode complex-character-string-widetag - simple-base-string-widetag complex-base-string-widetag)) - -(define-type-vop base-string-p - (simple-base-string-widetag complex-base-string-widetag)) - -(define-type-vop bit-vector-p - (simple-bit-vector-widetag complex-bit-vector-widetag)) - -#+sb-unicode -(define-type-vop character-string-p - (simple-character-string-widetag complex-character-string-widetag)) - -(define-type-vop vectorp - (complex-vector-widetag . - #.(append - (map 'list - #'saetp-typecode - *specialized-array-element-type-properties*) - (mapcan (lambda (saetp) - (when (saetp-complex-typecode saetp) - (list (saetp-complex-typecode saetp)))) - (coerce *specialized-array-element-type-properties* 'list))))) - -;;; Note that this "type VOP" is sort of an oddball; it doesn't so -;;; much test for a Lisp-level type as just expose a low-level type -;;; code at the Lisp level. It is used as a building block to help us -;;; to express things like the test for (TYPEP FOO '(VECTOR T)) -;;; efficiently in Lisp code, but it doesn't correspond to any type -;;; expression which would actually occur in reasonable application -;;; code. (Common Lisp doesn't have any natural way of expressing this -;;; type.) Thus, there's no point in building up the full machinery of -;;; associated backend type predicates and so forth as we do for -;;; ordinary type VOPs. -(define-type-vop complex-vector-p (complex-vector-widetag)) - -(define-type-vop simple-array-p - (simple-array-widetag . - #.(map 'list - #'saetp-typecode - *specialized-array-element-type-properties*))) - -(define-type-vop arrayp - (simple-array-widetag - complex-array-widetag - complex-vector-widetag . - #.(append - (map 'list - #'saetp-typecode - *specialized-array-element-type-properties*) - (mapcan (lambda (saetp) - (when (saetp-complex-typecode saetp) - (list (saetp-complex-typecode saetp)))) - (coerce *specialized-array-element-type-properties* 'list))))) - -(define-type-vop numberp - (bignum-widetag - ratio-widetag - single-float-widetag - double-float-widetag - #+long-float long-float-widetag - complex-widetag - complex-single-float-widetag - complex-double-float-widetag - #+long-float complex-long-float-widetag - . #.fixnum-lowtags)) - -(define-type-vop rationalp - (ratio-widetag bignum-widetag . #.fixnum-lowtags)) - -(define-type-vop integerp - (bignum-widetag . #.fixnum-lowtags)) - -(define-type-vop floatp - (single-float-widetag double-float-widetag #+long-float long-float-widetag)) - -(define-type-vop realp - (ratio-widetag - bignum-widetag - single-float-widetag - double-float-widetag - #+long-float long-float-widetag - . #.fixnum-lowtags)) - -#+sb-simd-pack -(define-type-vop simd-pack-p (simd-pack-widetag)) -#+sb-simd-pack-256 -(define-type-vop simd-pack-256-p (simd-pack-256-widetag)) - -(define-type-vop unbound-marker-p (unbound-marker-widetag) - #+x86-64 simple-type-predicate) - -;;; Not type vops, but generic over all backends -(macrolet ((def (name lowtag) - `(define-vop () - (:translate ,name) - (:policy :fast-safe) - (:args (x :scs (descriptor-reg))) - (:results (res :scs (unsigned-reg))) - (:result-types unsigned-num) - (:generator 2 (loadw res x 0 ,lowtag))))) - (def function-header-word fun-pointer-lowtag) - (def instance-header-word instance-pointer-lowtag)) diff -Nru sbcl-2.1.1/src/compiler/generic/layout-ids.lisp sbcl-2.1.11/src/compiler/generic/layout-ids.lisp --- sbcl-2.1.1/src/compiler/generic/layout-ids.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/layout-ids.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -71,7 +71,7 @@ SB-C::ABSTRACT-LEXENV SB-KERNEL:UNKNOWN-TYPE SB-KERNEL:CONS-TYPE -SB-C::IR2-PHYSENV +SB-C::IR2-ENVIRONMENT SB-C::BASIC-VAR SB-KERNEL:FUN-DESIGNATOR-TYPE SB-PRETTY::QUEUED-OP @@ -216,9 +216,10 @@ #-(or arm mips) 'signed-byte) ;;; There are a few wired IDs: -;;; 1 = T -;;; 2 = STRUCTURE-OBJECT -;;; 3 = LAYOUT +;;; 0 = T +;;; 1 = STRUCTURE-OBJECT +;;; 2 = WRAPPER if #+metaspace, unused if #-metaspace +;;; 3 = SB-VM:LAYOUT if #+metaspace, WRAPPER if #-metaspace ;;; 4 = SB-LOCKLESS::LIST-NODE (ecase layout-id-type (unsigned-byte diff -Nru sbcl-2.1.1/src/compiler/generic/objdef.lisp sbcl-2.1.11/src/compiler/generic/objdef.lisp --- sbcl-2.1.1/src/compiler/generic/objdef.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/objdef.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -32,9 +32,7 @@ ;;;; the primitive objects themselves -(define-primitive-object (cons :type cons - :lowtag list-pointer-lowtag - :alloc-trans cons) +(define-primitive-object (cons :type cons :lowtag list-pointer-lowtag) (car :ref-trans car :set-trans %rplaca :init :arg :cas-trans %compare-and-swap-car) (cdr :ref-trans cdr :set-trans %rplacd :init :arg @@ -182,7 +180,7 @@ ;;; hidden dependencies on primitive object sizes for the most part, ;;; 'ppc-assem.S' contains a literal constant that relies on knowing ;;; the precise size of a code object. Yes, there is a FIXME there :-) -;;; So, if you touch this, then fix that. +;;; So, if you touch this, then fix that. REALLY REALLY. (define-primitive-object (code :type code-component :lowtag other-pointer-lowtag :widetag code-header-widetag) @@ -198,20 +196,15 @@ ;; for the assembler code component, a cons holding a hash-table. ;; (the cons points from read-only to static space, but the hash-table ;; wants to be in dynamic space) + ;; The corresponding SETF function is defined using code-header-set + ;; on the slot index; and there's a special variant if #+darwin-jit. (debug-info :type t :ref-known (flushable) - :ref-trans %%code-debug-info - :set-known () - :set-trans (setf %code-debug-info)) - ;; Define this slot if the architecture might ever use fixups. - ;; x86-64 doesn't necessarily use them, depending on the feature set, - ;; but this keeps things consistent. - #+(or x86 x86-64) - (fixups :type t - :ref-known (flushable) - :ref-trans %code-fixups - :set-known () - :set-trans (setf %code-fixups)) + :ref-trans %%code-debug-info) + ;; Not all architectures use fixups. The slot is always present for consistency. + ;; The corresponding SETF function is defined using code-header-set + ;; on the slot index. + (fixups :type t :ref-known (flushable) :ref-trans %code-fixups) (constants :rest-p t)) (define-primitive-object (fdefn :type fdefn @@ -258,7 +251,7 @@ (defconstant simple-fun-source-slot 2) ; form and/or docstring (defconstant simple-fun-info-slot 3) ; type and possibly xref -#-(or x86 x86-64) +#-(or x86 x86-64 arm64) (define-primitive-object (return-pc :lowtag other-pointer-lowtag :widetag t) (return-point :c-type "unsigned char" :rest-p t)) @@ -271,6 +264,10 @@ :alloc-trans %alloc-closure) (fun :init :arg :ref-trans #+(or x86 x86-64) %closure-callee #-(or x86 x86-64) %closure-fun) + ;; 'fun' is an interior pointer to code, but we also need the base pointer + ;; for MPS. I'm trying to figure out how to avoid this word of overhead, + ;; but it works for the time being. + #+metaspace (code :ref-known (flushable) :ref-trans %closure-code) (info :rest-p t)) (define-primitive-object (funcallable-instance @@ -278,8 +275,7 @@ :widetag funcallable-instance-widetag :alloc-trans %make-funcallable-instance) (trampoline :init :funcallable-instance-tramp) - #-compact-instance-header (layout :set-trans %set-funcallable-instance-layout - :ref-trans %fun-layout) + #-compact-instance-header (layout :set-trans %set-fun-layout :ref-trans %fun-layout) ;; TODO: if we can switch places of 'function' and 'fsc-instance-slots' ;; (at least for the builds with compact-instance-header) ;; then for both funcallable and non-funcallable instances, @@ -324,7 +320,7 @@ (define-primitive-object (unwind-block) (uwp :c-type "struct unwind_block *") (cfp :c-type "lispobj *") - #-(or x86 x86-64) code + #-(or x86 x86-64 arm64) code entry-pc #+(and win32 x86) next-seh-frame #+(and win32 x86) seh-frame-handler @@ -336,7 +332,7 @@ (define-primitive-object (catch-block) (uwp :c-type "struct unwind_block *") (cfp :c-type "lispobj *") - #-(or x86 x86-64) code + #-(or x86 x86-64 arm64) code entry-pc #+(and win32 x86) next-seh-frame #+(and win32 x86) seh-frame-handler @@ -378,11 +374,20 @@ :set-trans %set-symbol-global-value :set-known ()) - (info :ref-trans symbol-info :ref-known (flushable) - :set-trans (setf symbol-info) + ;; The private accessor for INFO reads the slot verbatim. + ;; In contrast, the SYMBOL-INFO function always returns a PACKED-INFO + ;; instance (see info-vector.lisp) or NIL. The slot itself may hold a cons + ;; of the user's PLIST and a PACKED-INFO or just a PACKED-INFO. + ;; It can't hold a PLIST alone without wrapping in an extra cons cell. + (info :ref-trans symbol-%info :ref-known (flushable) + :set-trans (setf symbol-%info) :set-known () - :cas-trans %compare-and-swap-symbol-info - :type (or simple-vector list) + ;; IR2-CONVERT-CASSER only knows the arg order as (OBJECT OLD NEW), + ;; so as much as I'd like to name this (CAS SYMBOL-%INFO), + ;; it can't be that, because it'd need args of (OLD NEW OBJECT). + ;; This is a pretty close approximation of the desired name. + :cas-trans sb-impl::cas-symbol-%info + :type (or instance list) :init :null) (name :ref-trans symbol-name :init :arg) (package :ref-trans sb-xc:symbol-package @@ -449,23 +454,26 @@ ;;; If we can't do that for some reason - like, say, the safepoint page ;;; is located prior to 'struct thread', then these just become ordinary slots. (defglobal *thread-header-slot-names* - (append '(msan-xor-constant) + (append #+x86-64 + '(t-nil-constants + msan-xor-constant + ;; The following slot's existence must NOT be conditional on #+msan + msan-param-tls) ; = &__msan_param_tls #+immobile-space '(function-layout varyobj-space-addr varyobj-card-count varyobj-card-marks))) -#+sb-safepoint -(defglobal *thread-trailer-slots* (mapcar #'list *thread-header-slot-names*)) -#-sb-safepoint (macrolet ((assign-header-slot-indices () (let ((i 0)) `(progn ,@(mapcar (lambda (x) `(defconstant ,(symbolicate "THREAD-" x "-SLOT") ,(decf i))) *thread-header-slot-names*))))) - (assign-header-slot-indices) - (defglobal *thread-trailer-slots* nil)) + (assign-header-slot-indices)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant histogram-small-bins 32)) ; for consing size histogram ;;; this isn't actually a lisp object at all, it's a c structure that lives ;;; in c-land. However, we need sight of so many parts of it from Lisp that @@ -487,11 +495,7 @@ ;; Furthermore, it is technically possibly for a pthread_t to be smaller than a word ;; (a 4-byte identifier, not a pointer, on 64-bit) but that seems not to be true ;; for any system that we care about. - ;; - ;; And this slot is badly named, it should be "Pthread" since it's the POSIX - ;; (or emulated POSIX) thread object, not necessarily the OS's thread notion. - ;; - (os-thread :c-type #+(or win32 (not sb-thread)) "lispobj" + (os-thread :c-type #+(or win32 (not sb-thread)) "lispobj" ; actually is HANDLE #-(or win32 (not sb-thread)) "pthread_t") ;; Keep this first bunch of slots from binding-stack-pointer through alloc-region @@ -512,16 +516,11 @@ (alien-stack-pointer :c-type "lispobj *" :pointer t :special *alien-stack-pointer*) (stepping) - ;; The following slot's existence must NOT be conditional on #+msan - #+x86-64 (msan-param-tls) ; = &__msan_param_tls - (dynspace-addr) - (dynspace-card-count) - (dynspace-pte-base) ;; Deterministic consing profile recording area. (profile-data :c-type "uword_t *" :pointer t) - ;; Lisp needs only the first two fields of the alloc_region, so it's OK if the - ;; final 2 fields have offsets >= 128 from the base of the thread structure. - #+gencgc (alloc-region :c-type "struct alloc_region" :length 4) + ;; Thread-local allocation buffers + #+gencgc (boxed-tlab :c-type "struct alloc_region" :length 4) + #+gencgc (unboxed-tlab :c-type "struct alloc_region" :length 4) ;; END of slots to keep near the beginning. ;; This is the original address at which the memory was allocated, @@ -547,6 +546,8 @@ ;; a struct containing {starting, running, suspended, dead} ;; and some other state fields. (state-word :c-type "struct thread_state_word") + ;; Statistical CPU profiler data recording buffer + (sprof-data) #+x86 (tls-cookie) ; LDT index #+sb-thread (tls-size) @@ -554,7 +555,7 @@ ;; handling, we need to know if the machine context is in Lisp code ;; or not. On non-threaded targets, this is a global variable in ;; the runtime, but it's clearly a per-thread value. - #+sb-thread + #+(and sb-thread (not arm64)) (foreign-function-call-active :c-type "boolean") ;; Same as above for the location of the current control stack frame. #+(and sb-thread (not (or x86 x86-64))) @@ -566,10 +567,18 @@ (control-stack-pointer :c-type "lispobj *") #+mach-exception-handler (mach-port-name :c-type "mach_port_name_t") - ;; If we need the header slots, but they can't precede this structure - ;; for technical reasons having to do with no writable memory being there, - ;; then stuff them at the end, for lack of any place better. - ,@*thread-trailer-slots* + #+ppc64 (card-table) + + ;; allocation instrumenting + (tot-bytes-alloc-boxed) + (tot-bytes-alloc-unboxed) + (slow-path-allocs) + (et-allocator-mutex-acq) ; elapsed times + (et-find-freeish-page) + (et-bzeroing) + (obj-size-histo :c-type "size_histogram" + :length #.(+ histogram-small-bins sb-vm:n-word-bits)) + ;; The *current-thread* MUST be the last slot in the C thread structure. ;; It it the only slot that needs to be noticed by the garbage collector. (lisp-thread :pointer t :special sb-thread:*current-thread*)) diff -Nru sbcl-2.1.1/src/compiler/generic/parms.lisp sbcl-2.1.11/src/compiler/generic/parms.lisp --- sbcl-2.1.1/src/compiler/generic/parms.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/parms.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -79,11 +79,15 @@ ))) (let* ((spaces (append `((read-only ,ro-space-size) + #+(and win32 x86-64) + (seh-data ,(symbol-value '+backend-page-bytes+) win64-seh-data-addr) (linkage-table ,small-space-size) #+sb-safepoint ;; Must be just before NIL. (safepoint ,(symbol-value '+backend-page-bytes+) gc-safepoint-page-addr) - (static ,small-space-size)) + (static ,small-space-size) + #+darwin-jit + (static-code ,small-space-size)) #+immobile-space `((fixedobj ,fixedobj-space-size*) (varyobj ,varyobj-space-size*)))) @@ -127,7 +131,20 @@ (or ,(or (!read-dynamic-space-size) dynamic-space-size*) (ecase n-word-bits (32 (expt 2 29)) - (64 (expt 2 30))))))))) + (64 (expt 2 30))))) + (defconstant gencgc-card-shift + (integer-length (1- sb-vm:gencgc-card-bytes))) + ;; This is a constant during build, but a different value + ;; can be patched directly into the affected machine code + ;; when the core is loaded based on dynamic-space-size. + ;; I think the C runtime does a floor operation rather than ceiling, + ;; but firstly there's probably no difference, and secondly it's better + ;; to be safe than sorry - using too many bits rather than too few. + (defconstant gencgc-card-table-index-nbits + (integer-length (1- (ceiling sb-vm::default-dynamic-space-size + sb-vm::gencgc-card-bytes)))) + (defconstant gencgc-card-table-index-mask + (1- (ash 1 gencgc-card-table-index-nbits))))))) (defconstant-eqx +c-callable-fdefns+ '(sub-gc @@ -145,11 +162,9 @@ sb-di::handle-breakpoint sb-di::handle-single-step-trap #+win32 sb-kernel::handle-win32-exception - #+sb-thruption sb-thread::run-interruption + #+sb-safepoint sb-thread::run-interruption enter-alien-callback - #+sb-thread sb-thread::enter-foreign-callback - #+(and sb-safepoint-strictly (not win32)) - sb-unix::signal-handler-callback) + #+sb-thread sb-thread::enter-foreign-callback) #'equal) ;;; (potentially) static symbols that C code must be able to set/get @@ -163,9 +178,8 @@ `((*free-interrupt-context-index* 0) (sb-sys:*allow-with-interrupts* t) (sb-sys:*interrupts-enabled* t) - *alloc-signal* sb-sys:*interrupt-pending* - #+sb-thruption sb-sys:*thruption-pending* + #+sb-safepoint sb-sys:*thruption-pending* *in-without-gcing* *gc-inhibit* *gc-pending* @@ -194,6 +208,7 @@ *current-unwind-protect-block*) #+immobile-space *immobile-freelist* ; not per-thread (yet...) + #+metaspace *metaspace-tracts* ;; stack pointers #-sb-thread *binding-stack-start* ; a thread slot if #+sb-thread @@ -245,10 +260,12 @@ #-sb-thread 1024) ; crazy value ;;; Thread slots accessed at negative indices relative to struct thread. -;;; sb-safepoint needs to access one word below thread-base-tn for the -;;; foreign call safepoint trap word, so this trick doesn't work. (defconstant thread-header-slots - (+ #+(and x86-64 (not sb-safepoint)) 16)) + ;; This seems to need to be an even number. + ;; I'm not sure what the constraint on that stems from. + #+(and x86-64 sb-safepoint) 14 ; the safepoint trap page is at word index -15 + #+(and x86-64 (not sb-safepoint)) 16 + #-x86-64 0) #+gencgc (progn @@ -258,5 +275,47 @@ (defparameter *runtime-asm-routines* nil) (defparameter *linkage-space-predefined-entries* nil) +;;; Floating-point related constants, both format descriptions and FPU +;;; control register descriptions. These don't exactly match up with +;;; what the machine manuals say because the Common Lisp standard +;;; defines floating-point values somewhat differently than the IEEE +;;; standard does. + +;;; We can currently manipulate only IEEE single and double precision. +;;; Machine-specific formats (such as x86 80-bit and PPC double-double) +;;; are unsupported. + +#+ieee-floating-point +(progn +(defconstant float-sign-shift 31) + +;;; The exponent bias is the amount up by which the true exponent is +;;; incremented for storage purposes. +;;; (Wikipedia entry for single-float: "an exponent value of 127 represents the actual zero") +;;; 126 works for us because we actually want an exponent of -1 and not 0 +;;; when using DECODE-FLOAT. -1 is correct because the implied 1 bit in a normalized +;;; float is the _left_ of of the binary point, so the powers of 2 for the first represented +;;; bit is 2^-1. Similarly for double-float. +(defconstant single-float-bias 126) +(defconstant-eqx single-float-exponent-byte (byte 8 23) #'equalp) +(defconstant-eqx single-float-significand-byte (byte 23 0) #'equalp) +(defconstant single-float-normal-exponent-min 1) +(defconstant single-float-normal-exponent-max 254) +(defconstant single-float-hidden-bit (ash 1 23)) + +(defconstant double-float-bias 1022) +(defconstant-eqx double-float-exponent-byte (byte 11 20) #'equalp) +(defconstant-eqx double-float-significand-byte (byte 20 0) #'equalp) +(defconstant double-float-normal-exponent-min 1) +(defconstant double-float-normal-exponent-max #x7FE) +(defconstant double-float-hidden-bit (ash 1 20)) + +(defconstant single-float-digits + (+ (byte-size single-float-significand-byte) 1)) + +(defconstant double-float-digits + (+ (byte-size double-float-significand-byte) 32 1)) +) + (push '("SB-VM" +c-callable-fdefns+ +common-static-symbols+) *!removable-symbols*) diff -Nru sbcl-2.1.1/src/compiler/generic/primtype.lisp sbcl-2.1.11/src/compiler/generic/primtype.lisp --- sbcl-2.1.1/src/compiler/generic/primtype.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/primtype.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -142,13 +142,12 @@ ;;; Return the most restrictive primitive type that contains OBJECT. (/show0 "primtype.lisp 147") (defun primitive-type-of (object) - (let ((type (ctype-of object))) - (cond ((not (member-type-p type)) (primitive-type type)) - ((and (eql 1 (member-type-size type)) - (equal (member-type-members type) '(nil))) - (primitive-type-or-lose 'list)) - (t - *backend-t-primitive-type*)))) + (if (null object) + (load-time-value (primitive-type-or-lose 'list) t) + (let ((type (ctype-of object))) + (if (member-type-p type) + *backend-t-primitive-type* + (primitive-type type))))) ;;; Return the primitive type corresponding to a type descriptor ;;; structure. The second value is true when the primitive type is @@ -391,32 +390,27 @@ #+sb-simd-pack (simd-pack-type (let ((eltypes (simd-pack-type-element-type type))) - (cond ((member 'integer eltypes) + (cond ((equal '(integer) eltypes) (exactly simd-pack-int)) - ((member 'single-float eltypes) + ((equal '(single-float) eltypes) (exactly simd-pack-single)) - ((member 'double-float eltypes) - (exactly simd-pack-double))))) + ((equal '(double-float) eltypes) + (exactly simd-pack-double)) + (t (any))))) #+sb-simd-pack-256 (simd-pack-256-type (let ((eltypes (simd-pack-256-type-element-type type))) - (cond ((member 'integer eltypes) + (cond ((equal '(integer) eltypes) (exactly simd-pack-256-int)) - ((member 'single-float eltypes) + ((equal '(single-float) eltypes) (exactly simd-pack-256-single)) - ((member 'double-float eltypes) - (exactly simd-pack-256-double))))) + ((equal '(double-float) eltypes) + (exactly simd-pack-256-double)) + (t (any))))) (cons-type (part-of list)) (built-in-classoid (case (classoid-name type) - #+sb-simd-pack - ;; Can't tell what specific type; assume integers. - (simd-pack - (exactly simd-pack-int)) - #+sb-simd-pack-256 - (simd-pack-256 - (exactly simd-pack-256-int)) ((complex function system-area-pointer weak-pointer) (values (primitive-type-or-lose (classoid-name type)) t)) ((pathname logical-pathname) diff -Nru sbcl-2.1.1/src/compiler/generic/target-core.lisp sbcl-2.1.11/src/compiler/generic/target-core.lisp --- sbcl-2.1.1/src/compiler/generic/target-core.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/target-core.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,13 +18,11 @@ ;;; Map of code-component -> list of PC offsets at which allocations occur. ;;; This table is needed in order to enable allocation profiling. -(define-load-time-global *allocation-point-fixups* +(define-load-time-global *allocation-patch-points* (make-hash-table :test 'eq :weakness :key :synchronized t)) #-x86-64 (progn -(defun convert-alloc-point-fixups (dummy1 dummy2) - (declare (ignore dummy1 dummy2))) (defun sb-vm::statically-link-code-obj (code fixups) (declare (ignore code fixups)))) @@ -37,7 +35,7 @@ (defun sb-vm::function-raw-address (name &aux (fun (fdefinition name))) (cond ((not (immobile-space-obj-p fun)) (error "Can't statically link to ~S: code is movable" name)) - ((neq (fun-subtype fun) sb-vm:simple-fun-widetag) + ((neq (%fun-pointer-widetag fun) sb-vm:simple-fun-widetag) (error "Can't statically link to ~S: non-simple function" name)) (t (let ((addr (get-lisp-obj-address fun))) @@ -57,69 +55,80 @@ ;;; FUN must be pinned when calling this. (declaim (inline assign-simple-fun-self)) (defun assign-simple-fun-self (fun) - (setf (%simple-fun-self fun) - ;; x86 backends store the address of the entrypoint in 'self' - #+(or x86 x86-64) - (%make-lisp-obj - (truly-the word (+ (get-lisp-obj-address fun) - (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift) - (- sb-vm:fun-pointer-lowtag)))) - ;; non-x86 backends store the function itself (what else?) in 'self' - #-(or x86 x86-64) fun)) + (let ((self ;; x86 backends store the address of the entrypoint in 'self' + #+(or x86 x86-64) + (%make-lisp-obj + (truly-the word (+ (get-lisp-obj-address fun) + (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift) + (- sb-vm:fun-pointer-lowtag)))) + ;; non-x86 backends store the function itself (what else?) in 'self' + #-(or x86 x86-64) fun)) + #-darwin-jit + (setf (sb-vm::%simple-fun-self fun) self) + #+darwin-jit + (sb-vm::jit-patch (+ (get-lisp-obj-address fun) + (- sb-vm:fun-pointer-lowtag) + (* sb-vm:simple-fun-self-slot sb-vm:n-word-bytes)) + (get-lisp-obj-address self)))) -(flet ((fixup (code-obj offset sym kind flavor preserved-lists statically-link-p) +(flet ((fixup (code-obj offset name kind flavor preserved-lists statically-link-p) (declare (ignorable statically-link-p)) + ;; NAME depends on the kind and flavor of fixup. ;; PRESERVED-LISTS is a vector of lists of locations (by kind) ;; at which fixup must be re-applied after code movement. ;; CODE-OBJ must already be pinned in order to legally call this. ;; One call site that reaches here is below at MAKE-CORE-COMPONENT ;; and the other is LOAD-CODE, both of which pin the code. - ;; SYM is a little bit of a misnomer - it may be a generalized function name. - (when (sb-vm:fixup-code-object + (ecase + (sb-vm:fixup-code-object code-obj offset (ecase flavor ((:assembly-routine :assembly-routine* :asm-routine-nil-offset) - (- (or (get-asm-routine sym (eq flavor :assembly-routine*)) - (error "undefined assembler routine: ~S" sym)) + (- (or (get-asm-routine name (eq flavor :assembly-routine*)) + (error "undefined assembler routine: ~S" name)) (if (eq flavor :asm-routine-nil-offset) sb-vm:nil-value 0))) - (:foreign (foreign-symbol-address sym)) - (:foreign-dataref (foreign-symbol-address sym t)) + (:foreign (foreign-symbol-address name)) + (:foreign-dataref (foreign-symbol-address name t)) (:code-object (get-lisp-obj-address code-obj)) - #+sb-thread (:symbol-tls-index (ensure-symbol-tls-index sym)) + #+sb-thread (:symbol-tls-index (ensure-symbol-tls-index name)) (:layout (get-lisp-obj-address - (if (symbolp sym) (find-layout sym) sym))) - (:layout-id (layout-id sym)) - (:immobile-symbol (get-lisp-obj-address sym)) - (:symbol-value (get-lisp-obj-address (symbol-global-value sym))) + (wrapper-friend (if (symbolp name) (find-layout name) name)))) + (:layout-id (layout-id name)) + #+gencgc (:gc-barrier (extern-alien "gc_card_table_nbits" int)) + (:immobile-symbol (get-lisp-obj-address name)) + ;; It is legal to take the address of symbol-value only if the + ;; value is known to be an immobile object + ;; (whose address we don't want to wire in). + (:symbol-value (get-lisp-obj-address (symbol-global-value name))) #+immobile-code (:named-call - (prog1 (sb-vm::fdefn-entry-address sym) ; creates if didn't exist + (prog1 (sb-vm::fdefn-entry-address name) ; creates if didn't exist (when statically-link-p - (push (cons offset (find-fdefn sym)) (elt preserved-lists 0))))) - #+immobile-code (:static-call (sb-vm::function-raw-address sym))) + (push (cons offset (find-fdefn name)) (elt preserved-lists 0))))) + #+immobile-code (:static-call (sb-vm::function-raw-address name))) kind flavor) - (ecase kind - (:relative (push offset (elt preserved-lists 1))) - (:absolute (push offset (elt preserved-lists 2))) - (:absolute64 (push offset (elt preserved-lists 3))))) - ;; These won't exist except for x86-64, but it doesn't matter. - (when (member sym '(sb-vm::enable-alloc-counter - sb-vm::enable-sized-alloc-counter)) - (push offset (elt preserved-lists 4)))) + ((nil)) ; don't need to save it in the code-fixups, otherwise do + (:relative (push offset (elt preserved-lists 1))) + (:absolute (push offset (elt preserved-lists 2))) + (:immediate (push offset (elt preserved-lists 3))) + (:absolute64 (push offset (elt preserved-lists 4))))) (finish-fixups (code-obj preserved-lists) (declare (ignorable code-obj preserved-lists)) - #+(or x86 x86-64) + ;; PRESERVED-LISTS are somewhat backend-dependent, but essentially + ;; you get to store three lists that might as well have been named + ;; Larry, Moe, and Curly. (let ((rel-fixups (elt preserved-lists 1)) (abs-fixups (elt preserved-lists 2)) - (abs64-fixups (elt preserved-lists 3))) - (aver (not abs64-fixups)) ; no preserved 64-bit fixups - (when (or abs-fixups rel-fixups) + (gc-barrier-fixups (elt preserved-lists 3)) + (abs64-fixups (elt preserved-lists 4))) + ;; the fixup list packer only preserves at most 3 lists. + ;; And it's not clear that this is the best way to represent them. + (aver (not abs64-fixups)) + (when (or abs-fixups rel-fixups gc-barrier-fixups) (setf (sb-vm::%code-fixups code-obj) - (sb-c:pack-code-fixup-locs abs-fixups rel-fixups)))) - (awhen (elt preserved-lists 4) - (setf (gethash code-obj *allocation-point-fixups*) - (convert-alloc-point-fixups code-obj it))) + (sb-c:pack-code-fixup-locs abs-fixups rel-fixups gc-barrier-fixups)))) + ;; Assign all SIMPLE-FUN-SELF slots (dotimes (i (code-n-entries code-obj)) (let ((fun (%code-entry-point code-obj i))) @@ -129,7 +138,7 @@ (setf (sap-ref-32 (int-sap (get-lisp-obj-address fun)) (- 4 sb-vm:fun-pointer-lowtag)) (truly-the (unsigned-byte 32) - (get-lisp-obj-address #.(find-layout 'function)))))) + (get-lisp-obj-address (wrapper-friend #.(find-layout 'function))))))) ;; And finally, make the memory range executable #-(or x86 x86-64) (sb-vm:sanctify-for-execution code-obj) ;; Return fixups amenable to static linking @@ -138,11 +147,12 @@ (defun apply-fasl-fixups (fop-stack code-obj n-fixups &aux (top (svref fop-stack 0))) (dx-let ((preserved (make-array 5 :initial-element nil))) (macrolet ((pop-fop-stack () `(prog1 (svref fop-stack top) (decf top)))) + (binding* ((alloc-points (pop-fop-stack) :exit-if-null)) + (setf (gethash code-obj *allocation-patch-points*) alloc-points)) (dotimes (i n-fixups (setf (svref fop-stack 0) top)) (multiple-value-bind (offset kind flavor) (sb-fasl::!unpack-fixup-info (pop-fop-stack)) - (fixup code-obj offset (pop-fop-stack) kind flavor - preserved nil)))) + (fixup code-obj offset (pop-fop-stack) kind flavor preserved nil)))) (finish-fixups code-obj preserved))) (defun apply-core-fixups (fixup-notes code-obj) @@ -174,7 +184,10 @@ (copy (allocate-code-object :dynamic (code-n-named-calls code) boxed unboxed))) (with-pinned-objects (code copy) + #-darwin-jit (%byte-blt (code-instructions code) 0 (code-instructions copy) 0 unboxed) + #+darwin-jit + (sb-vm::jit-memcpy (code-instructions copy) (code-instructions code) unboxed) ;; copy boxed constants so that the fixup step (if needed) sees the 'fixups' ;; slot from the new object. (loop for i from 2 below boxed @@ -241,15 +254,15 @@ (defun assign-code-serialno (code-obj) (let* ((serialno (ldb (byte (byte-size sb-vm::code-serialno-byte) 0) - (atomic-incf sb-fasl::*code-serialno*))) + (atomic-incf *code-serialno*))) (insts (code-instructions code-obj)) (jumptable-word (sap-ref-word insts 0))) (aver (zerop (ash jumptable-word -14))) - (setf (sap-ref-word insts 0) ; insert serialno + (setf (sb-vm::sap-ref-word-jit insts 0) ; insert serialno (logior (ash serialno (byte-position sb-vm::code-serialno-byte)) jumptable-word)))) -(defun make-core-component (component segment length fixup-notes object) +(defun make-core-component (component segment length fixup-notes alloc-points object) (declare (type component component) (type segment segment) (type index length) @@ -259,11 +272,25 @@ (2comp (component-info component)) (constants (ir2-component-constants 2comp)) (nboxed (align-up (length constants) sb-c::code-boxed-words-align)) - (code-obj (allocate-code-object - (component-mem-space component) - (count-if (lambda (x) (typep x '(cons (eql :named-call)))) - constants) - nboxed length)) + (n-named-calls + ;; Pre-scan for fdefinitions to ensure their existence. + ;; Doing so guarantees that storing them into the boxed header now + ;; can't create any old->young pointer, which is important since gencgc + ;; does not deal with untagged pointers when looking for old->young. + (do ((count 0) + (index (+ sb-vm:code-constants-offset + (* (length (ir2-component-entries 2comp)) + sb-vm:code-slots-per-simple-fun)) + (1+ index))) + ((>= index (length constants)) count) + (let* ((const (aref constants index)) + (kind (if (listp const) (car const) const))) + (case kind + ((member :named-call :fdefinition) + (setf (second const) (find-or-create-fdefn (second const))) + (when (eq kind :named-call) (incf count))))))) + (code-obj (allocate-code-object (component-mem-space component) + n-named-calls nboxed length)) (named-call-fixups ;; The following operations need the code pinned: ;; 1. copying into code-instructions (a SAP) @@ -280,7 +307,12 @@ ;; is GC-safe because we no longer need to know where simple-funs are embedded ;; within the object to trace pointers. We *do* need to know where the funs ;; are when transporting the object, but it's currently pinned. + #-darwin-jit (%byte-blt bytes 0 (code-instructions code-obj) 0 (length bytes)) + #+darwin-jit + (with-pinned-objects (bytes) + (sb-vm::jit-memcpy (code-instructions code-obj) (vector-sap bytes) (length bytes))) + ;; Serial# shares a word with the jump-table word count, ;; so we can't assign serial# until after all raw bytes are copied in. (assign-code-serialno code-obj)) @@ -293,8 +325,14 @@ ;; That is, C code can't deal with an interior code pointer until the fun-table ;; is valid. This store must occur prior to calling %CODE-ENTRY-POINT, and ;; applying fixups calls %CODE-ENTRY-POINT, so we have to do this before that. - (setf (%code-debug-info code-obj) debug-info) - (apply-core-fixups fixup-notes code-obj)))) + (setf (%code-debug-info code-obj) debug-info) + (apply-core-fixups fixup-notes code-obj)))) + + (when alloc-points + #+(and x86-64 sb-thread) + (if (= (extern-alien "alloc_profiling" int) 0) ; record the object for later + (setf (gethash code-obj *allocation-patch-points*) alloc-points) + (funcall 'sb-aprof::patch-code code-obj alloc-points))) ;; Don't need code pinned now ;; (It will implicitly be pinned on the conservatively scavenged backends) @@ -304,6 +342,7 @@ (let ((fun (%code-entry-point code-obj (decf fun-index))) (w (+ sb-vm:code-constants-offset (* sb-vm:code-slots-per-simple-fun fun-index)))) + (aver (functionp fun)) ; in case %CODE-ENTRY-POINT returns NIL (setf (code-header-ref code-obj (+ w sb-vm:simple-fun-name-slot)) (entry-info-name entry-info) (code-header-ref code-obj (+ w sb-vm:simple-fun-arglist-slot)) @@ -330,8 +369,7 @@ (t (let ((referent (etypecase kind - ((member :named-call :fdefinition) - (find-or-create-fdefn (cadr const))) + ((member :named-call :fdefinition) (cadr const)) ((eql :known-fun) (%coerce-name-to-fun (cadr const))) (constant @@ -341,6 +379,9 @@ (setf (code-header-ref code-obj index) referent))))))) (when named-call-fixups (sb-vm::statically-link-code-obj code-obj named-call-fixups)) + (when sb-fasl::*show-new-code* + (let ((*print-pretty* nil)) + (format t "~&New code(~Db,core): ~A~%" (code-object-size code-obj) code-obj))) code-obj)) (defun set-code-fdefn (code index fdefn) diff -Nru sbcl-2.1.1/src/compiler/generic/type-error.lisp sbcl-2.1.11/src/compiler/generic/type-error.lisp --- sbcl-2.1.1/src/compiler/generic/type-error.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/type-error.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -44,26 +44,7 @@ (index :scs (unsigned-reg)) (value :scs (descriptor-reg))) (:arg-types simple-array-nil positive-fixnum *) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:ignore index value result) - (:vop-var vop) - (:save-p :compute-only) - (:generator 1 - (error-call vop 'nil-array-accessed-error object))) - -(define-vop (data-vector-set/simple-array-nil) - (:translate data-vector-set) - (:policy :fast-safe) - (:args (object :scs (descriptor-reg)) - (index :scs (unsigned-reg)) - (value :scs (descriptor-reg))) - (:info offset) - (:arg-types simple-array-nil positive-fixnum * - (:constant (integer 0 0))) - (:results (result :scs (descriptor-reg))) - (:result-types *) - (:ignore index value result offset) + (:ignore index value) (:vop-var vop) (:save-p :compute-only) (:generator 1 @@ -90,7 +71,7 @@ (cond ((sc-is thing immediate) (let ((obj (tn-value thing))) (typecase obj - (layout nil) + (wrapper nil) ;; non-static symbols can be referenced as error-break args ;; because they appear in the code constants. ;; static symbols can't be referenced as error-break args @@ -135,17 +116,14 @@ (def "FAILED-AVER" sb-impl::%failed-aver nil form)) -(defun emit-internal-error (kind code values &key trap-emitter - (compact-error-trap t)) - (let ((trap-number (if (and (eq kind error-trap) - compact-error-trap) +(defun emit-internal-error (kind code values &key trap-emitter) + (let ((trap-number (if (eq kind error-trap) (+ kind code) kind))) (if trap-emitter (funcall trap-emitter trap-number) (inst byte trap-number))) - (unless (and (eq kind error-trap) - compact-error-trap) + (unless (eq kind error-trap) (inst byte code)) (encode-internal-error-args values)) @@ -161,7 +139,7 @@ (make-sc+offset immediate-sc-number (tn-value where))) (t (make-sc+offset (if (and (sc-is where immediate) - (typep (tn-value where) '(or symbol layout))) + (typep (tn-value where) '(or symbol wrapper))) constant-sc-number (sc-number (tn-sc where))) (or (tn-offset where) 0)))) diff -Nru sbcl-2.1.1/src/compiler/generic/type-vops.lisp sbcl-2.1.11/src/compiler/generic/type-vops.lisp --- sbcl-2.1.1/src/compiler/generic/type-vops.lisp 1970-01-01 00:00:00.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/type-vops.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -0,0 +1,437 @@ +;;;; generic type testing and checking VOPs + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. +(in-package "SB-VM") + + +(defconstant-eqx +immediate-types+ + `(,unbound-marker-widetag ,character-widetag #+64-bit ,single-float-widetag) + #'equal) + +;; Given a list of widetags in HEADERS, compress into a minimal list of ranges +;; and/or singletons that should be tested. +;; FIXME: At present the "is it effectively a one-sided test" is re-implemented +;; in an ad-hoc way by each backend. The range convention should be +;; changed to indicate explicitly when either limit needn't be checked. +;; (Use NIL or * as a bound perhaps) +(eval-when (:compile-toplevel :load-toplevel :execute) + +(defun canonicalize-widetags (headers) + (collect ((results)) + (let ((start nil) + (prev nil) + (delta widetag-spacing)) + (flet ((emit-test () + (results (if (= start prev) + start + (cons start prev))))) + ;; COPY-LIST because the argument may come from immutable source code + (dolist (header (sort (copy-list headers) #'<)) + (cond ((null start) + (setf start header) + (setf prev header)) + ((= header (+ prev delta)) + (setf prev header)) + (t + (emit-test) + (setf start header) + (setf prev header)))) + (emit-test))) + (results))) + +;; If WIDETAGS is comprised of two ranges that are nearly adjacent, +;; return a single range spanning both original ranges, +;; and as a second value the widetag(s) to exclude; +;; or return the unmodified ranges and NIL. +;; This could be generalized: three ranges that collapse to one with at most +;; two exceptions, or three collapsing to two with one exception, etc. +(defun canonicalize-widetags+exceptions (widetags) + (let ((ranges (canonicalize-widetags widetags))) + (flet ((begin (x) (if (listp x) (car x) x)) + (end (x) (if (listp x) (cdr x) x))) + (when (and (cdr ranges) (endp (cddr ranges))) ; 2 ranges + (let* ((range-1 (first ranges)) + (range-2 (second ranges)) + (begin-1 (begin range-1)) + (end-1 (end range-1)) + (begin-2 (begin range-2)) + (end-2 (end range-2)) + (delta widetag-spacing)) + (when (and (= (+ end-1 (* 2 delta)) begin-2) + ;; Don't return {X} - {Y} if {X} spans only 3 widetags, + ;; because clearly we can just test the 2 members of X. + ;; fencepost: 3 delta is 4 widetags. + (>= (- end-2 begin-1) (* 3 delta))) + (return-from canonicalize-widetags+exceptions + (values `((,begin-1 . ,end-2)) + `(,(+ end-1 delta)))))))) ; the excluded value + (values ranges nil))) +) ; EVAL-WHEN + +(defmacro test-type (value temp target not-p + (&rest type-codes) + &rest other-args + &key &allow-other-keys) + ;; Determine what interesting combinations we need to test for. + (let* ((type-codes (mapcar #'eval type-codes)) + (fixnump (and (every (lambda (lowtag) + (member lowtag type-codes)) + '#.(mapcar #'symbol-value fixnum-lowtags)) + t)) + ;; On 64-bit, UNBOUND-MARKER-WIDETAG may be smaller than LOWTAG-LIMIT + ;; but it is not a lowtag. + (lowtags (remove unbound-marker-widetag + (remove lowtag-limit type-codes :test #'<))) + (extended (remove-if (lambda (x) + (and (< x lowtag-limit) + (/= x unbound-marker-widetag))) + type-codes)) + (immediates (intersection extended +immediate-types+ :test #'eql)) + ;; To collapse the range of widetags comprising real numbers on 64-bit + ;; machines, consider SHORT-FLOAT-WIDETAG both a header and immediate. + ;; No OTHER-POINTER-LOWTAG object can ever have that header tag. + ;; But only do so if there would otherwise be a discontinuity + ;; in the set of headers. + ;; Another approach would have been to flip DOUBLE- and SINGLE- float, + ;; but that would not help NUMBERP, only REALP. Putting SINGLE- + ;; after the complex widetags would work but harm 32-bit machines. + (headers (set-difference + extended + (if (and (= n-word-bits 64) + (member (- single-float-widetag 4) extended) + (member (+ single-float-widetag 4) extended)) + (remove single-float-widetag +immediate-types+) + +immediate-types+) + :test #'eql)) + (function-p (if (intersection headers +function-widetags+) + (if (subsetp headers +function-widetags+) + t + (error "can't test for mix of function subtypes ~ + and other header types")) + nil))) + (unless type-codes + (error "At least one type must be supplied for TEST-TYPE.")) + (unless headers + (remf other-args :value-tn-ref)) + (cond + (fixnump + (when (remove-if (lambda (x) + (member x '#.(mapcar #'symbol-value fixnum-lowtags))) + lowtags) + (error "can't mix fixnum testing with other lowtags")) + (when function-p + (error "can't mix fixnum testing with function subtype testing")) + (cond + ((and (= n-word-bits 64) immediates headers) + `(%test-fixnum-immediate-and-headers ,value ,temp ,target ,not-p + ,(car immediates) + ',(canonicalize-widetags + headers) + ,@other-args)) + (immediates + (if (= n-word-bits 64) + `(%test-fixnum-and-immediate ,value ,temp ,target ,not-p + ,(car immediates) + ,@other-args) + (error "can't mix fixnum testing with other immediates"))) + (headers + `(%test-fixnum-and-headers ,value ,temp ,target ,not-p + ',(canonicalize-widetags headers) + ,@other-args)) + (t + `(%test-fixnum ,value ,temp ,target ,not-p + ,@other-args)))) + (immediates + (cond + (headers + (if (= n-word-bits 64) + `(%test-immediate-and-headers ,value ,temp ,target ,not-p + ,(car immediates) + ',(canonicalize-widetags headers) + ,@other-args) + (error "can't mix testing of immediates with testing of headers"))) + (lowtags + (error "can't mix testing of immediates with testing of lowtags")) + ((cdr immediates) + (error "can't test multiple immediates at the same time")) + (t + `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates) + ,@other-args)))) + (lowtags + (when (cdr lowtags) + (error "can't test multiple lowtags at the same time")) + (when headers + (error "can't test non-fixnum lowtags and headers at the same time")) + `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags) ,@other-args)) + (headers + `(%test-headers ,value ,temp ,target ,not-p ,function-p + ',(canonicalize-widetags headers) + ,@other-args)) + (t + (error "nothing to test?"))))) + +;;; FIXME: backend-specific junk doesn't belong in compiler/generic. + +#+(or x86 x86-64) +(progn +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + ;; x86 code has to avoid 'esi' and 'edi' for the temp + ;; since they can't be accessed as an 8-bit byte. + ;; x86-64 being more regular, any reg can serve as the temp. + ;; In all likelihood, it'll get rax anyway just because. + (:temporary (:sc unsigned-reg #+x86 :offset #+x86 eax-offset) temp) + (:conditional) + (:info target not-p) + (:args-var args) + (:policy :fast-safe)) +(define-vop (simple-type-predicate) + (:args (value :scs (any-reg descriptor-reg control-stack))) + (:conditional) + (:info target not-p) + (:args-var args) + (:policy :fast-safe)) +;; A vop that accepts a computed set of widetags. +(define-vop (%other-pointer-subtype-p type-predicate) + (:translate %other-pointer-subtype-p) + (:info target not-p widetags) + (:arg-types * (:constant t)) ; voodoo - 'target' and 'not-p' are absent + (:generator 15 ; arbitrary + (multiple-value-bind (headers except) (canonicalize-widetags+exceptions widetags) + (%test-headers value temp target not-p nil headers :except except + :value-tn-ref args))))) + +#-(or x86 x86-64) +(progn +(define-vop (type-predicate) + (:args (value :scs (any-reg descriptor-reg))) + (:temporary (:sc non-descriptor-reg) temp) + (:conditional) + (:info target not-p) + (:args-var args) + (:policy :fast-safe)) +;; A vop that accepts a computed set of widetags. +(define-vop (%other-pointer-subtype-p type-predicate) + (:translate %other-pointer-subtype-p) + (:info target not-p widetags) + (:arg-types * (:constant t)) ; voodoo - 'target' and 'not-p' are absent + (:args-var args) + (:generator 15 ; arbitrary + (%test-headers value temp target not-p nil (canonicalize-widetags widetags) + :value-tn-ref args)))) + +(defmacro define-type-vop (pred-name type-codes + &optional (inherit 'type-predicate)) + (let ((cost (if (> (reduce #'max type-codes :key #'eval) lowtag-limit) + 7 + 4))) + `(define-vop (,pred-name ,inherit) + (:translate ,pred-name) + (:generator ,cost + (test-type value + ,(if (eq inherit 'simple-type-predicate) nil 'temp) + target not-p ,type-codes + :value-tn-ref args))))) + +#-x86-64 ; defined in compiler/x86-64/type-vops for x86-64 +(progn +(define-type-vop unbound-marker-p (unbound-marker-widetag)) + +(define-type-vop characterp (character-widetag)) + +#-arm-64 +(define-type-vop single-float-p (single-float-widetag)) + +(define-type-vop fixnump + #.fixnum-lowtags + #+(or x86) simple-type-predicate) ;; save a register + +(define-type-vop functionp (fun-pointer-lowtag)) + +(define-type-vop listp (list-pointer-lowtag)) + +(define-type-vop %instancep (instance-pointer-lowtag)) + +(define-type-vop %other-pointer-p (other-pointer-lowtag)) + +(define-type-vop non-null-symbol-p (symbol-widetag)) + +(define-type-vop closurep (closure-widetag)) + +(define-type-vop simple-fun-p (simple-fun-widetag)) + +(define-type-vop funcallable-instance-p (funcallable-instance-widetag)) +) ; end PROGN + +(define-type-vop bignump (bignum-widetag)) + +(define-type-vop ratiop (ratio-widetag)) + +(define-type-vop complexp + (complex-widetag complex-single-float-widetag complex-double-float-widetag + #+long-float complex-long-float-widetag)) + +(define-type-vop complex-rational-p (complex-widetag)) + +(define-type-vop complex-float-p + (complex-single-float-widetag complex-double-float-widetag + #+long-float complex-long-float-widetag)) + +(define-type-vop complex-single-float-p (complex-single-float-widetag)) + +(define-type-vop complex-double-float-p (complex-double-float-widetag)) + +(define-type-vop double-float-p (double-float-widetag)) + +(define-type-vop simple-string-p + (#+sb-unicode simple-character-string-widetag + simple-base-string-widetag)) + +#-x86-64 +(macrolet + ((define-simple-array-type-vops () + `(progn + ,@(map 'list + (lambda (saetp) + (let ((primtype (saetp-primitive-type-name saetp))) + `(define-type-vop + ,(symbolicate primtype "-P") + (,(saetp-typecode saetp))))) + *specialized-array-element-type-properties*)))) + (define-simple-array-type-vops)) + +(macrolet + ((def () + `(define-type-vop simple-rank-1-array-*-p + ,(map 'list #'saetp-typecode + *specialized-array-element-type-properties*)))) + (def)) ; simple-rank-1-array-*-p + +(define-type-vop system-area-pointer-p (sap-widetag)) + +(define-type-vop weak-pointer-p (weak-pointer-widetag)) + +(define-type-vop code-component-p (code-header-widetag)) + +#-(or x86 x86-64 arm64) (define-type-vop lra-p (return-pc-widetag)) + +(define-type-vop fdefn-p (fdefn-widetag)) + +(define-type-vop array-header-p + (simple-array-widetag + #+sb-unicode complex-character-string-widetag + complex-base-string-widetag complex-bit-vector-widetag + complex-vector-widetag complex-array-widetag)) + +(define-type-vop simple-array-header-p + (simple-array-widetag)) + +(define-type-vop stringp + (#+sb-unicode simple-character-string-widetag + #+sb-unicode complex-character-string-widetag + simple-base-string-widetag complex-base-string-widetag)) + +(define-type-vop base-string-p + (simple-base-string-widetag complex-base-string-widetag)) + +(define-type-vop bit-vector-p + (simple-bit-vector-widetag complex-bit-vector-widetag)) + +#+sb-unicode +(define-type-vop character-string-p + (simple-character-string-widetag complex-character-string-widetag)) + +(define-type-vop vectorp + (complex-vector-widetag . + #.(append + (map 'list + #'saetp-typecode + *specialized-array-element-type-properties*) + (mapcan (lambda (saetp) + (when (saetp-complex-typecode saetp) + (list (saetp-complex-typecode saetp)))) + (coerce *specialized-array-element-type-properties* 'list))))) + +;;; Note that this "type VOP" is sort of an oddball; it doesn't so +;;; much test for a Lisp-level type as just expose a low-level type +;;; code at the Lisp level. It is used as a building block to help us +;;; to express things like the test for (TYPEP FOO '(VECTOR T)) +;;; efficiently in Lisp code, but it doesn't correspond to any type +;;; expression which would actually occur in reasonable application +;;; code. (Common Lisp doesn't have any natural way of expressing this +;;; type.) Thus, there's no point in building up the full machinery of +;;; associated backend type predicates and so forth as we do for +;;; ordinary type VOPs. +(define-type-vop complex-vector-p (complex-vector-widetag)) + +(define-type-vop simple-array-p + (simple-array-widetag . + #.(map 'list + #'saetp-typecode + *specialized-array-element-type-properties*))) + +(define-type-vop arrayp + (simple-array-widetag + complex-array-widetag + complex-vector-widetag . + #.(append + (map 'list + #'saetp-typecode + *specialized-array-element-type-properties*) + (mapcan (lambda (saetp) + (when (saetp-complex-typecode saetp) + (list (saetp-complex-typecode saetp)))) + (coerce *specialized-array-element-type-properties* 'list))))) + +(define-type-vop numberp + (bignum-widetag + ratio-widetag + single-float-widetag + double-float-widetag + #+long-float long-float-widetag + complex-widetag + complex-single-float-widetag + complex-double-float-widetag + #+long-float complex-long-float-widetag + . #.fixnum-lowtags)) + +(define-type-vop rationalp + (ratio-widetag bignum-widetag . #.fixnum-lowtags)) + +(define-type-vop integerp + (bignum-widetag . #.fixnum-lowtags)) + +(define-type-vop floatp + (single-float-widetag double-float-widetag #+long-float long-float-widetag)) + +(define-type-vop realp + (ratio-widetag + bignum-widetag + single-float-widetag + double-float-widetag + #+long-float long-float-widetag + . #.fixnum-lowtags)) + +#+sb-simd-pack +(define-type-vop simd-pack-p (simd-pack-widetag)) +#+sb-simd-pack-256 +(define-type-vop simd-pack-256-p (simd-pack-256-widetag)) + +;;; Not type vops, but generic over all backends +(macrolet ((def (name lowtag) + `(define-vop () + (:translate ,name) + (:policy :fast-safe) + (:args (x :scs (descriptor-reg))) + (:results (res :scs (unsigned-reg))) + (:result-types unsigned-num) + (:generator 2 (loadw res x 0 ,lowtag))))) + (def function-header-word fun-pointer-lowtag) + (def instance-header-word instance-pointer-lowtag)) diff -Nru sbcl-2.1.1/src/compiler/generic/utils.lisp sbcl-2.1.11/src/compiler/generic/utils.lisp --- sbcl-2.1.1/src/compiler/generic/utils.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/utils.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -130,7 +130,7 @@ ;;; Make an environment-live stack TN for saving the SP for NLX entry. (defun make-nlx-sp-tn (env) - (physenv-live-tn + (environment-live-tn (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) env)) @@ -210,12 +210,90 @@ (not (types-equal-or-intersect (tn-ref-type tn-ref) (specifier-type '(eql nil)))))) +(defun stack-consed-p (object) + (let ((write (sb-c::tn-writes object))) ; list of write refs + (when (or (not write) ; grrrr, the only write is from a LOAD tn + ; and we don't know the corresponding normal TN? + (tn-ref-next write)) ; can't determine if > 1 write + (return-from stack-consed-p nil)) + (let ((vop (tn-ref-vop write))) + (when (not vop) ; wat? + (return-from stack-consed-p nil)) + (when (eq (vop-name vop) 'allocate-vector-on-stack) + (return-from stack-consed-p t)) + (when (and (eq (vop-name vop) 'fixed-alloc) + (fifth (vop-codegen-info vop))) ; STACK-ALLOCATE-P + (return-from stack-consed-p t)) + ;; Should we try to detect a stack-consed LIST also? + ;; I don't think that will work. + ;; (And is there anything else interesting to try?) + (unless (member (vop-name vop) '(splat-word splat-small splat-any)) + (return-from stack-consed-p nil)) + (let* ((splat-input (vop-args vop)) + (splat-input-source + (tn-ref-vop (sb-c::tn-writes (tn-ref-tn splat-input))))) + ;; How in the heck can there NOT be a vop??? Well, sometimes there isn't. + (when (and splat-input-source + (eq (vop-name splat-input-source) + 'allocate-vector-on-stack)) + (return-from stack-consed-p t))))) + nil) + +;;; Just gathering some data to see where we can improve +(define-load-time-global *store-barriers-potentially-emitted* 0) +(define-load-time-global *store-barriers-emitted* 0) + +(defun require-gc-store-barrier-p (object value-tn-ref value-tn) + (incf *store-barriers-potentially-emitted*) + ;; If OBJECT is stack-allocated, elide the barrier + (when (stack-consed-p object) + (return-from require-gc-store-barrier-p nil)) + (flet ((potential-heap-pointer-p (tn tn-ref) + (when (sc-is tn any-reg) ; must be fixnum + (return-from potential-heap-pointer-p nil)) + ;; If stack-allocated, elide the barrier + (when (stack-consed-p tn) + (return-from potential-heap-pointer-p nil)) + ;; If immediate non-pointer, elide the barrier + (when (sc-is tn immediate) + (let ((value (tn-value tn))) + (when (sb-xc:typep value '(or character sb-xc:fixnum boolean + #+64-bit single-float)) + (return-from potential-heap-pointer-p nil)))) + (when (sb-c::unbound-marker-tn-p tn) + (return-from potential-heap-pointer-p nil)) + ;; And elide for things like (OR FIXNUM NULL) + (let ((type (tn-ref-type tn-ref))) + (when (csubtypep type (specifier-type '(or character sb-xc:fixnum boolean + #+64-bit single-float))) + (return-from potential-heap-pointer-p nil))) + t)) + (cond (value-tn + (unless (eq (tn-ref-tn value-tn-ref) value-tn) + (aver (eq (tn-ref-load-tn value-tn-ref) value-tn))) + (unless (potential-heap-pointer-p value-tn value-tn-ref) + (return-from require-gc-store-barrier-p nil))) + (value-tn-ref ; a list of refs linked through TN-REF-ACROSS + ;; (presumably from INSTANCE-SET-MULTIPLE) + (let ((any-pointer + (do ((ref value-tn-ref (tn-ref-across ref))) + ((null ref)) + (when (potential-heap-pointer-p (tn-ref-tn ref) ref) + (return t))))) + (unless any-pointer + (return-from require-gc-store-barrier-p nil)))))) + (incf *store-barriers-emitted*) + t) + +(defun vop-nth-arg (n vop) + (let ((ref (vop-args vop))) + (dotimes (i n ref) (setq ref (tn-ref-across ref))))) + (defun length-field-shift (widetag) (if (= widetag instance-widetag) instance-length-shift n-widetag-bits)) -(defconstant array-rank-byte-pos 16) (defconstant array-rank-mask 255) ;;; Rank is encoded as a (UNSIGNED-BYTE 8) minus one. ;;; Initialization of simple rank 1 array header words is completely unaffected- @@ -232,8 +310,12 @@ (>= widetag complex-base-string-widetag)))) (logior (if array-header-p (let ((rank (- nwords array-dimensions-offset))) - (ash (encode-array-rank rank) array-rank-byte-pos)) + (ash (encode-array-rank rank) array-rank-position)) (case widetag (#.fdefn-widetag 0) (t (ash (1- nwords) (length-field-shift widetag))))) widetag))) + +(defmacro id-bits-offset () + (let ((slot (get-dsd-index layout sb-kernel::id-word0))) + (ash (+ sb-vm:instance-slots-offset slot) sb-vm:word-shift))) diff -Nru sbcl-2.1.1/src/compiler/generic/vm-array.lisp sbcl-2.1.11/src/compiler/generic/vm-array.lisp --- sbcl-2.1.1/src/compiler/generic/vm-array.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-array.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -62,21 +62,21 @@ ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07 (nil #:mu 0 simple-array-nil) #-sb-unicode - (character ,(code-char 0) 8 simple-base-string + (character ,(cl:code-char 0) 8 simple-base-string ;; (SIMPLE-BASE-STRINGs are stored with an extra ;; trailing #\NULL for convenience in calling out ;; to C.) :n-pad-elements 1 :complex-typecode #.complex-base-string-widetag) #+sb-unicode - (base-char ,(code-char 0) 8 simple-base-string + (base-char ,(cl:code-char 0) 8 simple-base-string ;; (SIMPLE-BASE-STRINGs are stored with an extra ;; trailing #\NULL for convenience in calling out ;; to C.) :n-pad-elements 1 :complex-typecode #.complex-base-string-widetag) #+sb-unicode - (character ,(code-char 0) 32 simple-character-string + (character ,(cl:code-char 0) 32 simple-character-string :complex-typecode #.complex-character-string-widetag) (single-float $0.0f0 32 simple-array-single-float) (double-float $0.0d0 64 simple-array-double-float) @@ -170,16 +170,36 @@ #-sb-xc-host '#.*vector-without-complex-typecode-infos*) -;;; Return the shift amount needed to turn length into bits +;;; Return the shift amount needed to turn length as number of elements +;;; into length as number of bits. (defun saetp-n-bits-shift (saetp) (max (1- (integer-length (saetp-n-bits saetp))) 0)) ;; because of NIL +#-sb-xc-host ; not computable as constant in make-host-1 +(defconstant-eqx %%simple-array-n-bits-shifts%% + #.(let ((a (sb-xc:make-array (1+ widetag-mask) :initial-element -1 ; "illegal" + :retain-specialization-for-after-xc-core t ; what a kludge! + :element-type '(signed-byte 8)))) + (dovector (saetp *specialized-array-element-type-properties* a) + (setf (aref a (saetp-typecode saetp)) (saetp-n-bits-shift saetp)))) + #'equalp) +(defun simple-array-widetag->bits-per-elt (widetag) + #+sb-xc-host (saetp-n-bits (find widetag *specialized-array-element-type-properties* + :key #'saetp-typecode)) + #-sb-xc-host (if (= widetag simple-array-nil-widetag) + 0 + (ash 1 (aref %%simple-array-n-bits-shifts%% widetag)))) + (defun saetp-index-or-lose (element-type) (or (position element-type sb-vm:*specialized-array-element-type-properties* :key #'sb-vm:saetp-specifier :test #'equal) (error "No saetp for ~S" element-type))) +;;; I don't understand why we didn't use this more often, instead of +;;; having introduced special cases. Oh well, what's done is done. +;;; At least you can grep for SAETP-N-PAD-ELEMENTS in the comments +;;; as a signal that the padding is calculated in yet another place. (defun vector-n-data-octets (vector saetp) (declare (type (simple-array * (*)) vector)) (let* ((length (+ (length vector) (saetp-n-pad-elements saetp))) @@ -191,6 +211,48 @@ (* length (ash n-bits -3)) (ash (* (+ length alignment-pad) n-bits) -3)))) +;;; Access the shadow bits for a simple rank-1 array +;;; It is important that the pointer to these bits be a normal full-lispword +;;; pointer, because otherwise update_page_write_prot() would fail to see +;;; the pointer to the shadow bits. +;;; Alternatively we could place them in malloc()'ed memory +;;; but then we'd need a finalizer per array. +#+ubsan +(progn +(export '(vector-extra-data)) +(defmacro vector-extra-data (vector) + `(%primitive slot ,vector 'length 1 other-pointer-lowtag)) +(defmacro set-vector-extra-data (vector data) + `(%primitive set-slot ,vector ,data 'length 1 other-pointer-lowtag)) +(defmacro unpoison (vector) + `(set-vector-extra-data ,vector 0))) +#-ubsan +(defmacro unpoison (vector) + (declare (ignore vector))) + +;;; Return T if arrays with the given WIDETAG may contain random data +;;; initially unless expressly initialized. +;;; Some types such as SB-VM:SIMPLE-ARRAY-FIXNUM-WIDETAG must not have +;;; random bits in them because a 1 in the LSB of a word would not be +;;; a fixnum, and could lead to corruption on use. +(defun array-may-contain-random-bits-p (widetag) + (if (member widetag + `(,simple-bit-vector-widetag + ,simple-base-string-widetag + #+sb-unicode ,simple-character-string-widetag + ,simple-array-unsigned-byte-2-widetag + ,simple-array-unsigned-byte-4-widetag + ,simple-array-unsigned-byte-8-widetag + ,simple-array-unsigned-byte-16-widetag + ,simple-array-unsigned-byte-32-widetag + #+64-bit ,simple-array-unsigned-byte-64-widetag + ,simple-array-signed-byte-8-widetag + ,simple-array-signed-byte-16-widetag + ,simple-array-signed-byte-32-widetag + #+64-bit ,simple-array-signed-byte-64-widetag)) + t + nil)) + (in-package "SB-C") (defun find-saetp (element-type) diff -Nru sbcl-2.1.1/src/compiler/generic/vm-fndb.lisp sbcl-2.1.11/src/compiler/generic/vm-fndb.lisp --- sbcl-2.1.1/src/compiler/generic/vm-fndb.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-fndb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -105,7 +105,7 @@ (defknown (%sxhash-simple-substring) (simple-string index index) hash-code (foldable flushable)) -(defknown (compute-symbol-hash) (simple-string index) hash-code +(defknown sb-impl::compute-symbol-hash (simple-string index) hash-code (foldable flushable)) (defknown (symbol-hash ensure-symbol-hash) (symbol) hash-code @@ -123,7 +123,12 @@ (defknown %set-symbol-hash (symbol hash-code) t ()) -(defknown symbol-info-vector (symbol) (or null simple-vector)) +;;; TODOD: I'd like to eliminate the (OR NULL) from this return type. +;;; For that to happen, I probably need +nil-packed-infos+ to become +;;; placed in static space because assembly routines may need it. +;;; On the other hand, they may not, because there is no special case +;;; code needed when reading from it, which is entire point. +(defknown symbol-dbinfo (symbol) (or null packed-info)) (defknown initialize-vector ((simple-array * (*)) &rest t) (simple-array * (*)) @@ -158,29 +163,35 @@ (defknown (function-header-word) (function) sb-vm:word (flushable)) (defknown (instance-header-word) (instance) sb-vm:word (flushable)) -;;; This unconventional setter returns its first arg, not the newval. (defknown set-header-data - (t (unsigned-byte #.(- sb-vm:n-word-bits sb-vm:n-widetag-bits))) t) -;;; Perform a bitwise OR or AND-not of the existing header data with -;;; the new bits and return no value. -(defknown (set-header-bits unset-header-bits) - (t (unsigned-byte #.(- sb-vm:n-word-bits sb-vm:n-widetag-bits))) (values) - ()) + (t (unsigned-byte #.(- sb-vm:n-word-bits sb-vm:n-widetag-bits))) (values)) +;;; Like SET-HEADER-DATA, but instead of writing the entire header, +;;; LOGIOR of the specified value into the "data" portion of the word. +;;; Returns the first argument, *not* the modified header data. +(defknown logior-header-bits (t (unsigned-byte 16)) t + (#+x86-64 always-translatable)) +;;; ASSIGN-VECTOR-FLAGSS assign all and only the flags byte. +;;; RESET- performs LOGANDC2 and returns no value. +(defknown (assign-vector-flags reset-header-bits) + (t (unsigned-byte 16)) (values) + (#+x86-64 always-translatable)) (defknown (test-header-bit) (t (unsigned-byte #.(- sb-vm:n-word-bits sb-vm:n-widetag-bits))) (boolean) (flushable)) (defknown %array-dimension (array index) index (flushable)) -(defknown %set-array-dimension (array index index) index +(defknown %set-array-dimension (array index index) (values) ()) (defknown %array-rank (array) array-rank (flushable)) -#+(or x86 x86-64) +#+(or x86 x86-64 arm64) (defknown (%array-rank= widetag=) (t t) boolean (flushable)) +(defknown simple-array-header-of-rank-p (t array-rank) boolean + (flushable)) (defknown sb-kernel::check-array-shape (simple-array list) (simple-array) (flushable) @@ -192,17 +203,23 @@ (flushable always-translatable)) (defknown (%copy-instance %copy-instance-slots) (instance instance) instance () :result-arg 0) -(defknown %instance-layout (instance) layout - (foldable flushable)) +(defknown %instance-layout (instance) sb-vm:layout (foldable flushable)) +(defknown %instance-wrapper (instance) wrapper (foldable flushable)) ;;; %FUN-LAYOUT is to %INSTANCE-LAYOUT as FUN-POINTER-LOWTAG is to INSTANCE-POINTER-LOWTAG (defknown %fun-layout (#-compact-instance-header funcallable-instance #+compact-instance-header function) - layout + sb-vm:layout (foldable flushable)) +(defknown %fun-wrapper (#-compact-instance-header funcallable-instance + #+compact-instance-header function) + wrapper (foldable flushable)) -(defknown %set-instance-layout (instance layout) layout - ()) -(defknown %set-funcallable-instance-layout (funcallable-instance layout) layout - ()) +(defknown %set-instance-layout (instance sb-vm:layout) (values) ()) +;;; %SET-FUN-LAYOUT should only called on FUNCALLABLE-INSTANCE +(defknown %set-fun-layout (funcallable-instance sb-vm:layout) (values) ()) +;;; Layout getter that accepts any object, and if it has INSTANCE- or FUN- +;;; POINTER-LOWTAG returns the layout, otherwise some agreed-upon layout. +(defknown %instanceoid-layout (t) sb-vm:layout (flushable)) +(defknown layout-eq ((or instance function) t (mod 16)) boolean (flushable)) ;;; Caution: This is not exactly the same as instance_length() in C. ;;; The C one is the same as SB-VM::INSTANCE-LENGTH. (defknown %instance-length (instance) (unsigned-byte 14) (foldable flushable)) @@ -211,10 +228,8 @@ (flushable always-translatable)) (defknown (%instance-ref-eq) (instance index t) boolean (flushable always-translatable)) -(defknown %instance-set (instance index t) t - (always-translatable) - :derive-type #'result-type-last-arg) -(defknown update-object-layout (t) layout) +(defknown %instance-set (instance index t) (values) (always-translatable)) +(defknown update-object-layout (t) sb-vm:layout) #+(or arm64 ppc ppc64 riscv x86 x86-64) (defknown %raw-instance-cas/word (instance index sb-vm:word sb-vm:word) @@ -222,26 +237,19 @@ #+riscv (defknown %raw-instance-cas/signed-word (instance index sb-vm:signed-word sb-vm:signed-word) sb-vm:signed-word ()) +(defknown %raw-instance-xchg/word (instance index sb-vm:word) sb-vm:word ()) #.`(progn ,@(map 'list (lambda (rsd) - (let* ((reader (sb-kernel::raw-slot-data-accessor-name rsd)) - (name (copy-seq (string reader))) - (writer (intern (replace name "-SET/" - :start1 (search "-REF/" name)))) + (let* ((reader (sb-kernel::raw-slot-data-reader-name rsd)) + (writer (sb-kernel::raw-slot-data-writer-name rsd)) (type (sb-kernel::raw-slot-data-raw-type rsd))) `(progn (defknown ,reader (instance index) ,type (flushable always-translatable)) - (defknown ,writer (instance index ,type) ,type - (always-translatable) :derive-type #'result-type-last-arg) - ;; Interpreter stubs, harmless but unnecessary on host - #-sb-xc-host - (progn (defun ,reader (instance index) - (,reader instance index)) - (defun ,writer (instance index new-value) - (,writer instance index new-value)))))) + (defknown ,writer (instance index ,type) (values) + (always-translatable))))) sb-kernel::*raw-slot-data*)) #+compare-and-swap-vops @@ -254,15 +262,24 @@ ;;; These two are mostly used for bit-bashing operations. (defknown %vector-raw-bits (t index) sb-vm:word (flushable)) -(defknown (%set-vector-raw-bits) (t index sb-vm:word) sb-vm:word - ()) +(defknown (%set-vector-raw-bits) (t index sb-vm:word) (values) ()) ;;; Allocate an unboxed, non-fancy vector with type code TYPE, length LENGTH, ;;; and WORDS words long. Note: it is your responsibility to ensure that the ;;; relation between LENGTH and WORDS is correct. ;;; The extra bit beyond N_WIDETAG_BITS is for the vector weakness flag. -(defknown allocate-vector ((unsigned-byte 9) index +;;; Note that in almost all situations the first argument is a constant. +;;; There are only 3 places that it can be non-constant, and not at all +;;; after self-build is complete. The three non-constant places are from: +;;; - ALLOCATE-VECTOR-WITH-WIDETAG in src/code/array +;;; - ALLOCATE-VECTOR (which is basically a stub) in src/code/array +;;; - FOP-SPEC-VECTOR which calls allocate-vector +;;; Apart from those, user code that does not have a compile-time-determined +;;; vector type will usuallly end up calling allocate-vector-with-widetag +;;; via %MAKE-ARRAY. +(defknown allocate-vector (#+ubsan boolean + word index ;; The number of words is later converted ;; to bytes, make sure it fits. (and index @@ -398,8 +415,10 @@ system-area-pointer (flushable)) (defknown (current-sp current-fp) () system-area-pointer (flushable)) (defknown current-fp-fixnum () fixnum (flushable)) +;; STACK-REF is pretty nearly just SAP-REF-LISPOBJ except that +;; it takes a word index, not a byte displacement from the SAP. (defknown stack-ref (system-area-pointer index) t (flushable)) -(defknown %set-stack-ref (system-area-pointer index t) t ()) +(defknown %set-stack-ref (system-area-pointer index t) (values) ()) (defknown lra-code-header (t) t (movable flushable)) ;; FUN-CODE-HEADER returns NIL for assembly routines that have a simple-fun header ;; with 0 as the data value. We should probably ensure that assembly routines @@ -429,62 +448,90 @@ ;;;; bignum operations (defknown %allocate-bignum (bignum-length) bignum - (flushable)) + (flushable #-bignum-assertions always-translatable)) (defknown %bignum-length (bignum) bignum-length - (foldable flushable)) + (foldable flushable always-translatable)) -(defknown %bignum-set-length (bignum bignum-length) bignum - ()) +;;; Change the length of bignum to be newlen. Newlen must be the same or +;;; smaller than the old length, and any elements beyond newlen must be zeroed. +(defknown %bignum-set-length (bignum bignum-length) (values) + (always-translatable)) (defknown %bignum-ref (bignum bignum-index) bignum-element-type - (flushable)) + (flushable #-bignum-assertions always-translatable)) #+(or x86 x86-64) (defknown %bignum-ref-with-offset (bignum fixnum (signed-byte 24)) bignum-element-type (flushable always-translatable)) -(defknown %bignum-set (bignum bignum-index bignum-element-type) - bignum-element-type - ()) +(defknown (%bignum-set #+bignum-assertions %%bignum-set) (bignum bignum-index bignum-element-type) + (values) + (#-bignum-assertions always-translatable)) +;;; Return T if digit is positive, or NIL if negative. (defknown %digit-0-or-plusp (bignum-element-type) boolean - (foldable flushable movable)) + (foldable flushable movable always-translatable)) +;;; %ADD-WITH-CARRY returns a bignum digit and a carry resulting from adding +;;; together a, b, and an incoming carry. +;;; %SUBTRACT-WITH-BOROW returns a bignum digit and a borrow resulting from +;;; subtracting b from a, and subtracting a possible incoming borrow. (defknown (%add-with-carry %subtract-with-borrow) (bignum-element-type bignum-element-type (mod 2)) (values bignum-element-type (mod 2)) - (foldable flushable movable)) + (foldable flushable movable always-translatable)) +;;; This multiplies x-digit and y-digit, producing high and low digits +;;; manifesting the result. Then it adds the low digit, res-digit, and +;;; carry-in-digit. Any carries (note, you still have to add two digits +;;; at a time possibly producing two carries) from adding these three +;;; digits get added to the high digit from the multiply, producing the +;;; next carry digit. Res-digit is optional since two uses of this +;;; primitive multiplies a single digit bignum by a multiple digit +;;; bignum, and in this situation there is no need for a result buffer +;;; accumulating partial results which is where the res-digit comes +;;; from. (defknown %multiply-and-add (bignum-element-type bignum-element-type bignum-element-type &optional bignum-element-type) (values bignum-element-type bignum-element-type) - (foldable flushable movable)) + (foldable flushable movable always-translatable)) +;;; Multiply two digit-size numbers, returning a 2*digit-size result +;;; split into two digit-size quantities. (defknown %multiply (bignum-element-type bignum-element-type) (values bignum-element-type bignum-element-type) - (foldable flushable movable)) + (foldable flushable movable always-translatable)) (defknown %lognot (bignum-element-type) bignum-element-type - (foldable flushable movable)) + (foldable flushable movable always-translatable)) (defknown (%logand %logior %logxor) (bignum-element-type bignum-element-type) bignum-element-type (foldable flushable movable)) (defknown %fixnum-to-digit (fixnum) bignum-element-type - (foldable flushable movable)) + (foldable flushable movable #-(or arm arm64) always-translatable)) +;;; This takes three digits and returns the FLOOR'ed result of +;;; dividing the first two as a 2*digit-size integer by the third. (defknown %bigfloor (bignum-element-type bignum-element-type bignum-element-type) (values bignum-element-type bignum-element-type) - (foldable flushable movable)) + (foldable flushable movable always-translatable)) +;;; Convert the input, a BIGNUM-ELEMENT-TYPE, to a signed word. +;;; FIXME: considering that both the input and output have N-WORD-BITS significant bits, +;;; this is really a bad name for the operation. (defknown %fixnum-digit-with-correct-sign (bignum-element-type) sb-vm:signed-word - (foldable flushable movable)) + (foldable flushable movable always-translatable)) +;;; %ASHR- take a digit-size quantity and shift it to the left, +;;; returning a digit-size quantity. +;;; %ASHR- Do an arithmetic shift right of data even though bignum-element-type is +;;; unsigned. (defknown (%ashl %ashr %digit-logical-shift-right) (bignum-element-type (mod #.sb-vm:n-word-bits)) bignum-element-type - (foldable flushable movable)) + (foldable flushable movable always-translatable)) ;;;; bit-bashing routines @@ -528,13 +575,13 @@ ;;; Extract the INDEXth element from the header of CODE-OBJ. Can be ;;; set with SETF. (defknown code-header-ref (code-component index) t (flushable)) -(defknown code-header-set (code-component index t) t ()) +(defknown code-header-set (code-component index t) (values) ()) ;;; Extract a 4-byte element relative to the end of CODE-OBJ. ;;; The index should be strictly negative and a multiple of 4. (defknown code-trailer-ref (code-component fixnum) (unsigned-byte 32) (flushable #-(or sparc ppc64) always-translatable)) -(defknown fun-subtype (function) (member . #.sb-vm::+function-widetags+) +(defknown %fun-pointer-widetag (function) (member . #.sb-vm::+function-widetags+) (flushable)) (defknown make-fdefn (t) fdefn (flushable movable)) @@ -542,7 +589,7 @@ (defknown fdefn-name (fdefn) t (foldable flushable)) (defknown fdefn-fun (fdefn) (or function null) (flushable)) (defknown (setf fdefn-fun) (function fdefn) t ()) -(defknown fdefn-makunbound (fdefn) t ()) +(defknown fdefn-makunbound (fdefn) (values) ()) ;;; FDEFN -> FUNCTION, trapping if not FBOUNDP (defknown safe-fdefn-fun (fdefn) function ()) @@ -553,6 +600,7 @@ (defknown %closure-index-ref (function index) t (flushable)) +(defknown %closure-index-set (function index t) (values) ()) ;; T argument is for the 'fun' slot. (defknown sb-vm::%alloc-closure (index t) function (flushable)) @@ -563,7 +611,8 @@ ()) (defknown %funcallable-instance-info (function index) t (flushable)) -(defknown %set-funcallable-instance-info (function index t) t ()) +(defknown (setf %funcallable-instance-info) (t function index) t ()) +(defknown %set-funcallable-instance-info (function index t) (values) ()) #+sb-fasteval (defknown sb-interpreter:fun-proto-fn (interpreted-function) diff -Nru sbcl-2.1.1/src/compiler/generic/vm-ir2tran.lisp sbcl-2.1.11/src/compiler/generic/vm-ir2tran.lisp --- sbcl-2.1.1/src/compiler/generic/vm-ir2tran.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-ir2tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -39,7 +39,9 @@ (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag) (let* ((lvar (node-lvar node)) - (locs (lvar-result-tns lvar (list *universal-type*))) + (locs (lvar-result-tns lvar (list (if lvar + (lvar-type lvar) + *universal-type*)))) (res (first locs))) (vop slot node block (lvar-tn node block object) name offset lowtag res) @@ -87,12 +89,6 @@ (slot (cdr init))) (case kind (:slot - ;; FIXME: the only reason INIT-SLOT raw variants exist is to avoid - ;; an extra MOVE - setters return a value, but INITers don't. - ;; It would probably produce better code by not assuming that - ;; setters return a value, because as things are, if you call - ;; 8 setters in a row, then you probably produce 7 extraneous moves, - ;; because not all of them can deliver a value to the final result. (let ((raw-type (pop slot)) (arg (pop args))) (unless (and (or (eq raw-type t) @@ -100,32 +96,30 @@ (zero-init-p arg)) (let ((arg-tn (lvar-tn node block arg))) (macrolet - ((make-case (&aux (rsd-list - (if (vop-existsp :named sb-vm::raw-instance-init/word) - sb-kernel::*raw-slot-data*))) + ((make-case (&aux (rsd-list sb-kernel::*raw-slot-data*)) `(ecase raw-type ((t) - (vop init-slot node block object arg-tn - name dx-p (+ sb-vm:instance-slots-offset slot) lowtag)) + (vop set-slot node block object arg-tn + name (+ sb-vm:instance-slots-offset slot) lowtag)) ,@(map 'list (lambda (rsd) `(,(sb-kernel::raw-slot-data-raw-type rsd) - (vop ,(sb-kernel::raw-slot-data-init-vop rsd) - node block object arg-tn slot))) + (vop ,(sb-kernel::raw-slot-data-writer-name rsd) + node block object (emit-constant slot) arg-tn))) rsd-list)))) (make-case)))))) + ;; compact header passes the layout to EMIT-FIXED-ALLOC + ;; which generates the instruction to set the header. + #-compact-instance-header (:dd - (vop init-slot node block object + (vop set-slot node block object (emit-constant (sb-kernel::dd-layout-or-lose slot)) - name dx-p - ;; Layout has no index if compact headers. - (or #+compact-instance-header :layout sb-vm:instance-slots-offset) - lowtag)) + name sb-vm:instance-slots-offset lowtag)) (otherwise (if (and (eq kind :arg) (zero-init-p (car args))) (pop args) - (vop init-slot node block object + (vop set-slot node block object (ecase kind (:arg (aver args) @@ -152,10 +146,17 @@ nil sb-vm:any-reg-sc-number))) (vop make-funcallable-instance-tramp node block tn) tn))))) - name dx-p slot lowtag)))))))) + name slot lowtag)))))))) (unless (null args) (bug "Leftover args: ~S" args))) +(defun unbound-marker-tn-p (tn) + (let ((writes (tn-writes tn))) + (and writes + (not (tn-ref-next writes)) ; is never changed + (let ((vop (tn-ref-vop writes))) + (and vop (eq (vop-name vop) 'make-unbound-marker)))))) + (defun emit-fixed-alloc (node block name words type lowtag result lvar) (let ((stack-allocate-p (and lvar (lvar-dynamic-extent lvar)))) (when stack-allocate-p @@ -214,46 +215,54 @@ (array-type-specialized-element-type vector-ctype) (bug "Unknown vector type in IR2 conversion for ~S." 'initialize-vector))) + (bit-vector-p (type= elt-ctype (specifier-type 'bit))) (saetp (find-saetp-by-ctype elt-ctype)) (lvar (node-lvar node)) (locs (lvar-result-tns lvar (list vector-ctype))) (result (first locs)) (elt-ptype (primitive-type elt-ctype)) (tmp (make-normal-tn elt-ptype))) + (declare (ignorable bit-vector-p)) (emit-move node block (lvar-tn node block vector) result) (flet ((compute-setter () + ;; Such cringe. I had no idea why all the "-C" vops were mandatory. + ;; Too bad we can't let the backend decide how it would like to do things. + ;; Not to mention, this code is confusing because RESULT is the argument, + ;; and TN - the value to store - is the result, and an argument. + ;; Also note that the constant-index vops want the operands to the + ;; VOP macro as (VECTOR VALUE INDEX OFFSET) + (RESULT) + ;; but the non-constant want (VECTOR INDEX VALUE OFFSET) + (RESULT). + ;; They could totally have been made the same. (macrolet ((frob () - (let ((*package* (find-package :sb-vm)) - (clauses nil)) - (map nil (lambda (s) - (when (sb-vm:saetp-specifier s) - (push - `(,(sb-vm:saetp-typecode s) - (lambda (index tn) - #+x86-64 - (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" - (sb-vm:saetp-primitive-type-name s) - "-C") - node block result tn index 0 tn) - #+x86 - (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" - (sb-vm:saetp-primitive-type-name s)) - node block result index tn 0 tn) - #-(or x86 x86-64) - (vop ,(symbolicate "DATA-VECTOR-SET/" - (sb-vm:saetp-primitive-type-name s)) - node block result index tn tn))) - clauses))) - sb-vm:*specialized-array-element-type-properties*) - `(ecase (sb-vm:saetp-typecode saetp) - ,@(nreverse clauses))))) + `(ecase (sb-vm:saetp-typecode saetp) + ,@(map 'list + (lambda (s &aux (ptype (sb-vm:saetp-primitive-type-name s)) + (*package* (find-package "SB-VM"))) + `(,(sb-vm:saetp-typecode s) + (lambda (index tn) + #+x86-64 + ,(if (eq ptype 'simple-bit-vector) ; no "-C" setter exists + `(vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype) + node block result index tn 0) + `(vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype "-C") + node block result tn index 0)) + #+x86 + (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype) + node block result index tn 0) + #-(or x86 x86-64) + (vop ,(symbolicate "DATA-VECTOR-SET/" ptype) + node block result index tn)))) + (remove nil sb-vm:*specialized-array-element-type-properties* + :key #'sb-vm:saetp-specifier))))) (frob))) (tnify (index) #-x86-64 (emit-constant index) #+x86-64 - index)) + (if bit-vector-p ; moar cringe + (emit-constant index) + index))) (let ((setter (compute-setter)) (length (length initial-contents)) (dx-p (and lvar @@ -268,17 +277,21 @@ (if character (eql (char-code (lvar-value value)) 0) (eql (lvar-value value) 0))) - (emit-move node block (lvar-tn node block value) tmp) - (funcall setter (tnify i) tmp)))))) + ;; With SIMPLE-BIT-VECTOR, prefer to pass a constant TN if we can, as it emits + ;; better code (at least on x86-64) by using the constant to discern between + ;; the BTS or BTR opcode. However, a new suboptimality comes from that, + ;; which is that by not passing a LOCATION= TN for the output, the final MOVE + ;; in the setter thinks that it has to do something. + ;; Nonetheless it's far better than it was. In all other scenarios, don't pass + ;; a constant TN, because we don't know that generated code is better. + (cond #+x86-64 ; still moar cringe + ((and bit-vector-p (constant-lvar-p value)) + (funcall setter (tnify i) (emit-constant (lvar-value value)))) + (t + (emit-move node block (lvar-tn node block value) tmp) + (funcall setter (tnify i) tmp)))))))) (move-lvar-result node block locs lvar))) -(defun vector-initialized-p (call) - (let ((lvar (node-lvar call))) - (when lvar - (let ((dest (principal-lvar-dest lvar))) - (and (basic-combination-p dest) - (lvar-fun-is (basic-combination-fun dest) '(initialize-vector))))))) - ;;; An array header for simple non-unidimensional arrays is a fixed alloc, ;;; because the rank has to be known. ;;; (There are no compile-time optimizations for unknown rank arrays) @@ -317,8 +330,8 @@ args dx t) (defoptimizer (allocate-vector stack-allocate-result) - ((type length words) node dx) - (declare (ignorable type) (ignore length)) + ((#+ubsan poisoned type length words) node dx) + (declare (ignorable #+ubsan poisoned type length)) (and ;; Can't put unboxed data on the stack unless we scavenge it ;; conservatively. @@ -336,11 +349,14 @@ (specifier-type `(integer 0 ,(- (/ +backend-page-bytes+ sb-vm:n-word-bytes) sb-vm:vector-data-offset))))))) -(defoptimizer (allocate-vector ltn-annotate) ((type length words) call ltn-policy) - (declare (ignore type length words)) - (vectorish-ltn-annotate-helper call ltn-policy - 'sb-vm::allocate-vector-on-stack - 'sb-vm::allocate-vector-on-heap)) +(defoptimizer (allocate-vector ltn-annotate) + ((#+ubsan poisoned type length words) call ltn-policy) + (declare (ignore #+ubsan poisoned type length words)) + (vectorish-ltn-annotate-helper call ltn-policy + (if (sb-c:msan-unpoison sb-c:*compilation*) + 'sb-vm::allocate-vector-on-stack+msan-unpoison + 'sb-vm::allocate-vector-on-stack) + 'sb-vm::allocate-vector-on-heap)) (defun vectorish-ltn-annotate-helper (call ltn-policy dx-template not-dx-template) (let* ((args (basic-combination-args call)) @@ -351,12 +367,9 @@ (dolist (arg args) (setf (lvar-info arg) (make-ir2-lvar (primitive-type (lvar-type arg))))) - (unless (is-ok-template-use template call (ltn-policy-safe-p ltn-policy)) - (ltn-default-call call) - (return-from vectorish-ltn-annotate-helper (values))) + (aver (is-ok-template-use template call (ltn-policy-safe-p ltn-policy))) (setf (basic-combination-info call) template) (setf (node-tail-p call) nil) - (dolist (arg args) (annotate-1-value-lvar arg)))) @@ -401,36 +414,62 @@ 'sb-vm::allocate-list-on-stack 'sb-vm::allocate-list-on-heap))) +;;; Return the vop that wrote the TN referenced by TN-REF, +;;; but look through MOVEs. +(defun producer-vop (tn-ref) + (let ((vop (tn-ref-vop (tn-writes (tn-ref-tn tn-ref))))) + (if (neq (vop-name vop) 'move) + vop + (tn-ref-vop (tn-writes (tn-ref-tn (vop-args vop))))))) + +(defun elide-zero-fill (vop) + (let* ((writer (producer-vop (vop-args vop))) + ;; Take the last of the info arguments + ;; in case WORDS is also an info argument. + (value + (the (or sb-vm:word + (member :trap :unbound :safe-default :unsafe-default)) + (car (last (vop-codegen-info vop))))) + (elidep + (ecase (vop-name writer) + (sb-vm::allocate-vector-on-heap + (member value '(0 :safe-default :unsafe-default))) + ((sb-vm::allocate-vector-on-stack + sb-vm::allocate-vector-on-stack+msan-unpoison) + ;; For most specialized vectors, any random bits can + ;; be regarded as a :SAFE-DEFAULT. If :UNSAFE-DEFAULT, then random + ;; bits are OK (even for SIMPLE-VECTOR if not using precise gencgc). + (eq value :unsafe-default))))) + (when elidep ; change it to a MOVE + (let ((new (emit-and-insert-vop (vop-node vop) (vop-block vop) + (template-or-lose 'move) + (reference-tn (tn-ref-tn (vop-args vop)) nil) + (reference-tn (tn-ref-tn (vop-results vop)) t) + vop))) + (delete-vop vop) + new)))) (in-package "SB-VM") ;;; Return a list of parameters with which to call MAKE-ARRAY-HEADER* ;;; given the mandatory slots for a simple array of rank 0 or > 1. (defun make-array-header-inits (storage n-elements dimensions) - (nconc (mapcar (lambda (slot) - (ecase (slot-name slot) - (data storage) - (fill-pointer n-elements) - (elements n-elements) - (displacement 0) - (displaced-p nil) - (displaced-from nil))) - (butlast (primitive-object-slots - (find 'array *primitive-objects* - :key 'primitive-object-name)))) - dimensions)) + (let ((primitive-obj (load-time-value (primitive-object 'array) t))) + (nconc (loop with slots = (primitive-object-slots primitive-obj) + for i from 0 below (1- (length slots)) + collect + (let ((slot (svref slots i))) + (ecase (slot-name slot) + (data storage) + (fill-pointer n-elements) + (elements n-elements) + (displacement 0) + (displaced-p nil) + (displaced-from nil)))) + dimensions))) ;;; This order is used by SB-C::TRANSFORM-MAKE-ARRAY-VECTOR ;;; The slot formerly known as FILL-POINTER-P is 1 bit in the header now. -(assert (equal (mapcar #'slot-name - (primitive-object-slots - (find 'array *primitive-objects* - :key 'primitive-object-name))) +(assert (equal (map 'list #'slot-name + (primitive-object-slots (primitive-object 'array))) '(fill-pointer elements data displacement displaced-p displaced-from dimensions))) - -(defun emit-code-page-write-barrier-p (fun-name) - (and (listp fun-name) - (eq (car fun-name) 'setf) - (member (cadr fun-name) - '(%code-debug-info %code-fixups)) - t)) diff -Nru sbcl-2.1.1/src/compiler/generic/vm-macs.lisp sbcl-2.1.11/src/compiler/generic/vm-macs.lisp --- sbcl-2.1.1/src/compiler/generic/vm-macs.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-macs.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -32,30 +32,25 @@ (list* (car options) (cadr options) (remove-keywords (cddr options) keywords))))) -(defstruct (prim-object-slot - (:constructor make-slot (name rest-p offset special options)) - (:copier nil) - (:conc-name slot-)) - (name nil :type symbol :read-only t) - (rest-p nil :type (member t nil) :read-only t) - (offset 0 :type fixnum :read-only t) - (options nil :type list :read-only t) - ;; On some targets (e.g. x86-64) slots of the thread structure are - ;; referenced as special variables, this slot holds the name of that variable. - (special nil :type symbol :read-only t)) - (defstruct (primitive-object (:copier nil)) (name nil :type symbol :read-only t) (widetag nil :type symbol :read-only t) (lowtag nil :type symbol :read-only t) - (options nil :type list :read-only t) - (slots nil :type list :read-only t) (length 0 :type fixnum :read-only t) - (variable-length-p nil :type (member t nil) :read-only t)) + (variable-length-p nil :type boolean :read-only t) + (slots #() :type vector :read-only t)) + +(defun slot-offset (slot) (car slot)) +(defun slot-name (slot) (cadr slot)) +(defun slot-special (slot) (getf (cddr slot) :special)) -(declaim (freeze-type prim-object-slot primitive-object)) +(declaim (freeze-type primitive-object)) (define-load-time-global *primitive-objects* nil) +(defun primitive-object (name) + (find name *primitive-objects* :key #'primitive-object-name)) +(defun primitive-object-slot (obj name) + (find name (primitive-object-slots obj):key #'slot-name)) (defun !%define-primitive-object (primobj) (let ((name (primitive-object-name primobj))) @@ -89,8 +84,10 @@ &allow-other-keys) (if (atom spec) (list spec) spec) (declare (ignorable pointer)) - (slots `(make-slot ',slot-name ,rest-p ,offset ',special - ',(remove-keywords options '(:rest-p :length)))) + (slots (list* offset slot-name + (remove-keywords + options + `(#+sb-xc :c-type :rest-p ,@(if (= length 1) '(:length)))))) (let ((offset-sym (symbolicate name "-" slot-name (if rest-p "-OFFSET" "-SLOT")))) (constants @@ -141,7 +138,7 @@ (make-primitive-object :name ',name :widetag ',widetag :lowtag ',lowtag - :slots (list ,@(slots)) + :slots ,(coerce (slots) 'vector) :length ,offset :variable-length-p ,variable-length-p)) ,@(constants) diff -Nru sbcl-2.1.1/src/compiler/generic/vm-tran.lisp sbcl-2.1.11/src/compiler/generic/vm-tran.lisp --- sbcl-2.1.1/src/compiler/generic/vm-tran.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -37,10 +37,10 @@ (define-source-transform %make-symbol (kind string) (declare (ignore kind)) ;; Set "logically read-only" bit in pname. - `(sb-vm::%%make-symbol (set-header-data ,string ,sb-vm:+vector-shareable+))) + `(sb-vm::%%make-symbol (logior-array-flags ,string ,sb-vm:+vector-shareable+))) ;;; We don't want to clutter the bignum code. -#+(or x86 x86-64) +#+(and (or x86 x86-64) (not bignum-assertions)) (define-source-transform sb-bignum:%bignum-ref (bignum index) ;; KLUDGE: We use TRULY-THE here because even though the bignum code ;; is (currently) compiled with (SAFETY 0), the compiler insists on @@ -55,6 +55,15 @@ #+(or x86 x86-64) (defun fold-index-addressing (fun-name element-size lowtag data-offset index offset &optional setter-p) + ;; UNINITIALIZED-ELEMENT-ERROR does not take the ADDEND, + ;; so we need to make sure that it's always 0 for #+ubsan. + ;; #-ubsan has a minor problem in terms of error-reporting. + ;; The condition report method does not try to show the index of the + ;; trapping element, so we're at least not wrong. A good solution might be + ;; to have separate 2-arg and 3-arg variants of UNINITIALIZED-ELEMENT, + ;; or else always emit the addend even if zero. As things are, a 0 in the + ;; error payload eats 4 bytes due to design choices in sc+offset encoding. + #+ubsan (give-up-ir1-transform) (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2) (destructuring-bind (x constant) index-args (unless (and (constant-lvar-p constant) @@ -99,7 +108,7 @@ (class-eq (and name (eq (classoid-state classoid) :sealed) (not (classoid-subclasses classoid)))) - (dd (and class-eq (layout-info layout))) + (dd (and class-eq (wrapper-info layout))) (max-inlined-words 5)) (unless (and result ; could be unused result (but entire call wasn't flushed?) layout @@ -129,16 +138,18 @@ ;; ASSUMPTION: either %INSTANCE-REF is the correct accessor for this word, ;; or the GC will treat random bit patterns as conservative pointers ;; (i.e. not alter them if %INSTANCE-REF is not the correct accessor) - (setf ,@(loop for i from sb-vm:instance-data-start below (dd-length dd) - append `((%instance-ref copy ,i) (%instance-ref instance ,i)))) + ,@(loop for i from sb-vm:instance-data-start below (dd-length dd) + collect `(%instance-set copy ,i (%instance-ref instance ,i))) copy)) (t `(%copy-instance-slots (%make-structure-instance ,dd nil) instance))))) (defun varying-length-struct-p (classoid) ;; This is a nice feature to have in general, but at present it is only possible - ;; to make varying length instances of LAYOUT and nothing else. - (eq (classoid-name classoid) 'layout)) + ;; to make varying length instances of SB-VM:LAYOUT (or WRAPPER if that is the same type), + ;; and nothing else. + (eq classoid (load-time-value (find-classoid #+metaspace 'sb-vm:layout + #-metaspace 'wrapper)))) (deftransform %instance-length ((instance)) (let ((classoid (lvar-type instance))) @@ -148,9 +159,12 @@ (not (varying-length-struct-p classoid)) ;; TODO: if sealed with subclasses which add no slots, use the fixed length (not (classoid-subclasses classoid))) - (dd-length (layout-dd (sb-kernel::compiler-layout-or-lose (classoid-name classoid)))) + (dd-length (wrapper-dd (sb-kernel::compiler-layout-or-lose (classoid-name classoid)))) (give-up-ir1-transform)))) +(define-source-transform %instance-wrapper (x) `(layout-friend (%instance-layout ,x))) +(define-source-transform %fun-wrapper (x) `(layout-friend (%fun-layout ,x))) + ;;; *** These transforms should be the only code, aside from the C runtime ;;; with knowledge of the layout index. #+compact-instance-header @@ -158,9 +172,9 @@ #-compact-instance-header (progn (define-source-transform %instance-layout (x) - `(truly-the layout (%instance-ref ,x 0))) - (define-source-transform %set-instance-layout (x val) - `(%instance-set ,x 0 (the layout ,val))) + `(truly-the sb-vm:layout (%instance-ref ,x 0))) + (define-source-transform %set-instance-layout (instance layout) + `(%instance-set ,instance 0 (the sb-vm:layout ,layout))) (define-source-transform function-with-layout-p (x) `(funcallable-instance-p ,x))) @@ -176,9 +190,7 @@ (data-vector-ref string index)) #+sb-unicode ((simple-array base-char (*)) - (data-vector-ref string index)) - ((simple-array nil (*)) - (data-nil-vector-ref string index)))))) + (data-vector-ref string index)))))) ;;; This and the corresponding -SET transform work equally well on non-simple ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases @@ -188,7 +200,7 @@ "avoid runtime dispatch on array element type" (let* ((type (lvar-type array)) (element-ctype (array-type-upgraded-element-type type)) - (declared-element-ctype (array-type-declared-element-type type))) + (declared-element-ctype (declared-array-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -207,8 +219,7 @@ ((type= element-ctype declared-element-ctype) bare-form) (t - `(the ,(type-specifier declared-element-ctype) - ,bare-form)))))))) + (the-unwild declared-element-ctype bare-form)))))))) ;;; Transform multi-dimensional array to one dimensional data vector ;;; access. @@ -261,16 +272,18 @@ (if (array-type-p ctype) ;; the other transform will kick in, so that's OK (give-up-ir1-transform) + ;; HAIRY-DATA-VECTOR-SET returns a value but DATA-VECTOR-SET does not, + ;; so explicitly return the NEW-VALUE `(typecase string ((simple-array character (*)) - (data-vector-set string index (the* (character :context :aref) new-value))) + (let ((c (the* (character :context :aref) new-value))) + (data-vector-set string index c) + c)) #+sb-unicode ((simple-array base-char (*)) - (data-vector-set string index (the* (base-char :context :aref - :silent-conflict t) - new-value))) - (t - (%type-check-error/c string 'nil-array-accessed-error nil)))))) + (let ((c (the* (base-char :context :aref :silent-conflict t) new-value))) + (data-vector-set string index c) + c)))))) ;;; This and the corresponding -REF transform work equally well on non-simple ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases @@ -282,7 +295,7 @@ "avoid runtime dispatch on array element type" (let* ((type (lvar-type array)) (element-ctype (array-type-upgraded-element-type type)) - (declared-element-ctype (array-type-declared-element-type type))) + (declared-element-ctype (declared-array-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -293,11 +306,11 @@ (declare (type (simple-array ,element-type-specifier 1) array) (type ,element-type-specifier new-value)) ,(if (type= element-ctype declared-element-ctype) - '(data-vector-set array index new-value) - `(truly-the ,(type-specifier declared-element-ctype) - (data-vector-set array index - (the ,(type-specifier declared-element-ctype) - new-value)))))))) + '(progn (data-vector-set array index new-value) + new-value) + `(progn (data-vector-set array index + ,(the-unwild declared-element-ctype 'new-value)) + ,(truly-the-unwild declared-element-ctype 'new-value))))))) ;;; Transform multi-dimensional array to one dimensional data vector ;;; access. @@ -418,52 +431,37 @@ ;;;; BIT-VECTOR hackery ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word -;;; loop that does 32 bits at a time. -;;; -;;; FIXME: This is a lot of repeatedly macroexpanded code. It should -;;; be a function call instead. -(macrolet ((def (bitfun wordfun) - `(deftransform ,bitfun ((bit-array-1 bit-array-2 result-bit-array) - (simple-bit-vector - simple-bit-vector - simple-bit-vector) - * - :node node :policy (>= speed space)) - `(progn - ,@(unless (policy node (zerop safety)) - '((unless (= (length bit-array-1) - (length bit-array-2) - (length result-bit-array)) - (error "Argument and/or result bit arrays are not the same length:~ +;;; loop that does N-WORD-BITS bits at a time. +;;; Note that all of these array operations cause the unused bits +;;; of the last word to be operated on, so they are effectively +;;; in an indeterminate state which is why equality testing, COUNT, +;;; and FIND have to ignore them. +(deftransform bit-op->word-op ((bit-array-1 bit-array-2 result-bit-array) + (simple-bit-vector simple-bit-vector simple-bit-vector) + * + :node node :defun-only t :info wordfun) + `(let ((length (vector-length result-bit-array))) + ,@(unless (policy node (zerop safety)) + `((unless (= length + ,@(unless (same-leaf-ref-p bit-array-1 result-bit-array) + '((vector-length bit-array-1))) + (vector-length bit-array-2)) + (error "Argument and/or result bit arrays are not the same length:~ ~% ~S~% ~S ~% ~S" - bit-array-1 - bit-array-2 - result-bit-array)))) - (let ((length (length result-bit-array))) - (if (= length 0) - ;; We avoid doing anything to 0-length - ;; bit-vectors, or rather, the memory that - ;; follows them. Other divisible-by-32 cases - ;; are handled by the (1- length), below. - ;; CSR, 2002-04-24 - result-bit-array - (do ((index 0 (1+ index)) - ;; bit-vectors of length 1-32 need - ;; precisely one (SETF %VECTOR-RAW-BITS), - ;; done here in the epilogue. - CSR, - ;; 2002-04-24 - (end-1 (truncate (truly-the index (1- length)) - sb-vm:n-word-bits))) - ((>= index end-1) - (setf (%vector-raw-bits result-bit-array index) - (,',wordfun (%vector-raw-bits bit-array-1 index) - (%vector-raw-bits bit-array-2 index))) - result-bit-array) - (declare (optimize (speed 3) (safety 0)) - (type index index end-1)) - (setf (%vector-raw-bits result-bit-array index) - (,',wordfun (%vector-raw-bits bit-array-1 index) - (%vector-raw-bits bit-array-2 index)))))))))) + bit-array-1 bit-array-2 result-bit-array)))) + (dotimes (index (ceiling length sb-vm:n-word-bits)) + (declare (optimize (speed 3) (safety 0)) (type index index)) + (setf (%vector-raw-bits result-bit-array index) + (,wordfun (%vector-raw-bits bit-array-1 index) + (%vector-raw-bits bit-array-2 index)))) + result-bit-array)) + +(flet ((policy-test (node) (policy node (>= speed space)))) +(macrolet ((def (bitfun wordfun) + `(%deftransform ',bitfun #'policy-test + '(function (simple-bit-vector simple-bit-vector simple-bit-vector) + *) + (cons #'bit-op->word-op ',wordfun)))) (def bit-and word-logical-and) (def bit-ior word-logical-or) (def bit-xor word-logical-xor) @@ -473,178 +471,108 @@ (def bit-andc1 word-logical-andc1) (def bit-andc2 word-logical-andc2) (def bit-orc1 word-logical-orc1) - (def bit-orc2 word-logical-orc2)) + (def bit-orc2 word-logical-orc2))) (deftransform bit-not ((bit-array result-bit-array) (simple-bit-vector simple-bit-vector) * :node node :policy (>= speed space)) `(progn - ,@(unless (policy node (zerop safety)) - '((unless (= (length bit-array) - (length result-bit-array)) + ,@(unless (or (policy node (zerop safety)) + (same-leaf-ref-p bit-array result-bit-array)) + '((unless (= (vector-length bit-array) + (vector-length result-bit-array)) (error "Argument and result bit arrays are not the same length:~ ~% ~S~% ~S" bit-array result-bit-array)))) - (let ((length (length result-bit-array))) - (if (= length 0) - ;; We avoid doing anything to 0-length bit-vectors, or rather, - ;; the memory that follows them. Other divisible-by - ;; n-word-bits cases are handled by the (1- length), below. - ;; CSR, 2002-04-24 - result-bit-array - (do ((index 0 (1+ index)) - ;; bit-vectors of length 1 to n-word-bits need precisely - ;; one (SETF %VECTOR-RAW-BITS), done here in the - ;; epilogue. - CSR, 2002-04-24 - (end-1 (truncate (truly-the index (1- length)) - sb-vm:n-word-bits))) - ((>= index end-1) - (setf (%vector-raw-bits result-bit-array index) - (word-logical-not (%vector-raw-bits bit-array index))) - result-bit-array) - (declare (optimize (speed 3) (safety 0)) - (type index index end-1)) - (setf (%vector-raw-bits result-bit-array index) - (word-logical-not (%vector-raw-bits bit-array index)))))))) + (let ((length (vector-length result-bit-array))) + (dotimes (index (ceiling length sb-vm:n-word-bits)) + (declare (optimize (speed 3) (safety 0)) (type index index)) + (setf (%vector-raw-bits result-bit-array index) + (word-logical-not (%vector-raw-bits bit-array index)))) + result-bit-array))) +;;; This transform has to deal with the fact that unused bits +;;; in the last data word of a simple-bit-vector can be random. (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector)) ;; TODO: unroll if length is known and not more than a few words - `(and (= (length x) (length y)) - (let ((length (length x))) - (or (= length 0) - (do* ((i 0 (+ i 1)) - (end-1 (floor (1- length) sb-vm:n-word-bits))) - ((>= i end-1) - (let* ((extra (1+ (mod (1- length) sb-vm:n-word-bits))) - ;; Why do we need to mask anything? Do we allow use of - ;; the extra bits to record data steganographically? - ;; Or maybe we didn't zero-fill trailing bytes of stack-allocated - ;; bit-vectors? - (mask (ash sb-ext:most-positive-word (- extra sb-vm:n-word-bits))) - (numx - (logand - (ash mask - ,(ecase sb-c:*backend-byte-order* - (:little-endian 0) - (:big-endian - '(- sb-vm:n-word-bits extra)))) - (%vector-raw-bits x i))) - (numy - (logand - (ash mask - ,(ecase sb-c:*backend-byte-order* - (:little-endian 0) - (:big-endian - '(- sb-vm:n-word-bits extra)))) - (%vector-raw-bits y i)))) - (declare (type (integer 1 #.sb-vm:n-word-bits) extra) - (type sb-vm:word mask numx numy)) - (= numx numy))) - (declare (type index i end-1)) - (let ((numx (%vector-raw-bits x i)) - (numy (%vector-raw-bits y i))) - (declare (type sb-vm:word numx numy)) - (unless (= numx numy) - (return nil)))))))) + `(let ((length (vector-length x))) + (and (= (vector-length y) length) + (let ((words (floor length sb-vm:n-word-bits))) + (and (dotimes (i words t) + (unless (= (%vector-raw-bits x i) (%vector-raw-bits y i)) + (return nil))) + (let ((remainder (mod length sb-vm:n-word-bits))) + (or (zerop remainder) + ;; - To examine 1 bit, shift over 63 bits, 0-filling on the other side + ;; - To examine 2 bits, shift over 62 bits, etc + ;; SHIFT-TOWARDS-END accepts a negative shift COUNT which is + ;; congruent to desired shift modulo the maximum shift. + (zerop (shift-towards-end (logxor (%vector-raw-bits x words) + (%vector-raw-bits y words)) + (- remainder)))))))))) +;;; This transform has to deal with the fact that unused bits +;;; in the last data word of a simple-bit-vector can be random. (deftransform count ((item sequence) (bit simple-bit-vector) * :policy (>= speed space)) - ;; TODO: unroll if length is known and not more than a few words - `(let ((length (length sequence))) - (if (zerop length) - 0 - (do ((index 0 (1+ index)) - (count 0) - (end-1 (truncate (truly-the index (1- length)) - sb-vm:n-word-bits))) - ((>= index end-1) - ;; "(mod (1- length) ...)" is the bit index within the word - ;; of the array index of the ultimate bit to be examined. - ;; "1+" it is the number of bits in that word. - ;; But I don't get why people are allowed to store random data that - ;; we mask off, as if we could accomodate all possible ways that - ;; unsafe code can spew bits where they don't belong. - ;; Does it have to do with %shrink-vector, perhaps? - ;; Some rationale would be nice... - (let* ((extra (1+ (mod (1- length) sb-vm:n-word-bits))) - (mask (ash most-positive-word (- extra sb-vm:n-word-bits))) - ;; The above notwithstanding, for big-endian wouldn't it - ;; be possible to write this expression as a single shift? - ;; (LOGAND MOST-POSITIVE-WORD (ASH most-positive-word (- n-word-bits extra))) - ;; rather than a right-shift to fill in zeros on the left - ;; then by a left-shift to left-align the 1s? - (bits (logand (ash mask - ,(ecase sb-c:*backend-byte-order* - (:little-endian 0) - (:big-endian - '(- sb-vm:n-word-bits extra)))) - (%vector-raw-bits sequence index)))) - (declare (type (integer 1 #.sb-vm:n-word-bits) extra)) - (declare (type sb-vm:word mask bits)) - (incf count (logcount bits)) - ,(if (constant-lvar-p item) - (if (zerop (lvar-value item)) - '(- length count) - 'count) - '(if (zerop item) - (- length count) - count)))) - (declare (type index index count end-1) - (optimize (speed 3) (safety 0))) - (incf count (logcount (%vector-raw-bits sequence index))))))) - -(deftransform fill ((sequence item) (simple-bit-vector bit) * + `(let* ((length (vector-length sequence)) + (count 0) + (words (floor length sb-vm:n-word-bits))) + (declare (index count)) + (declare (optimize (speed 3) (safety 0))) + (dotimes (i words) + (incf count (logcount (%vector-raw-bits sequence i)))) + (let ((remainder (mod length sb-vm:n-word-bits))) + (unless (zerop remainder) + (incf count (logcount (shift-towards-end (%vector-raw-bits sequence words) + (- sb-vm:n-word-bits remainder)))))) + ,(if (constant-lvar-p item) + (if (zerop (lvar-value item)) '(- length count) 'count) + '(if (zerop item) (- length count) count)))) + +;;; This transform does not require that ITEM be derived as BIT, +;;; but at runtime it has to be. +(deftransform fill ((sequence item) (simple-bit-vector t) * :policy (>= speed space)) - (let ((value (if (constant-lvar-p item) - (if (= (lvar-value item) 0) - 0 - most-positive-word) - `(if (= item 0) 0 ,most-positive-word)))) - `(let ((length (length sequence)) - (value ,value)) - (if (= length 0) - sequence - (do ((index 0 (1+ index)) - ;; bit-vectors of length 1 to n-word-bits need precisely - ;; one (SETF %VECTOR-RAW-BITS), done here in the - ;; epilogue. - CSR, 2002-04-24 - (end-1 (truncate (truly-the index (1- length)) - sb-vm:n-word-bits))) - ((>= index end-1) - (setf (%vector-raw-bits sequence index) value) - sequence) - (declare (optimize (speed 3) (safety 0)) - (type index index end-1)) - (setf (%vector-raw-bits sequence index) value)))))) - -(deftransform fill ((sequence item) (simple-base-string base-char) * - :policy (>= speed space)) - (let ((value (if (constant-lvar-p item) - (let* ((char (lvar-value item)) - (code (sb-xc:char-code char)) - (accum 0)) - (dotimes (i sb-vm:n-word-bytes accum) - (setf accum (logior accum (ash code (* 8 i)))))) - `(let ((code (sb-xc:char-code item))) - (setf code (dpb code (byte 8 8) code)) - (setf code (dpb code (byte 16 16) code)) - (dpb code (byte 32 32) code))))) - `(let ((length (length sequence)) - (value ,value)) - (multiple-value-bind (times rem) - (truncate length sb-vm:n-word-bytes) - (do ((index 0 (1+ index)) - (end times)) - ((>= index end) - (let ((place (* times sb-vm:n-word-bytes))) - (declare (fixnum place)) - (dotimes (j rem sequence) - (declare (index j)) - (setf (schar sequence (the index (+ place j))) item)))) - (declare (optimize (speed 3) (safety 0)) - (type index index)) - (setf (%vector-raw-bits sequence index) value)))))) + `(let ((value (logand (- (the bit item)) most-positive-word))) + ;; Unlike for the SIMPLE-BASE-STRING case, we are allowed to touch + ;; bits beyond LENGTH with impunity. + (dotimes (index (ceiling (vector-length sequence) sb-vm:n-word-bits)) + (declare (optimize (speed 3) (safety 0)) + (type index index)) + (setf (%vector-raw-bits sequence index) value)) + sequence)) + +(deftransform fill ((sequence item) (simple-base-string t) * + :policy (>= speed space)) + (let ((multiplier (logand #x0101010101010101 most-positive-word))) + `(let* ((value ,(if (and (constant-lvar-p item) (typep item 'base-char)) + (* multiplier (char-code (lvar-value item))) + ;; Use multiplication if it's known to be cheap + #+(or x86 x86-64) + `(* ,multiplier (char-code (the base-char item))) + #-(or x86 x86-64) + '(let ((code (char-code (the base-char item)))) + (setf code (dpb code (byte 8 8) code)) + (setf code (dpb code (byte 16 16) code)) + #+64-bit (dpb code (byte 32 32) code)))) + (len (vector-length sequence)) + (words (truncate len sb-vm:n-word-bytes))) + (dotimes (index words) + (declare (optimize (speed 3) (safety 0)) + (type index index)) + (setf (%vector-raw-bits sequence index) value)) + ;; For 64-bit: + ;; if 1 more byte should be written, then shift-towards-start 56 + ;; if 2 more bytes ... then shift-towards-start 48 + ;; etc + ;; This correctly rewrites the trailing null in its proper place. + (let ((bits (ash (mod len sb-vm:n-word-bytes) 3))) + (when (plusp bits) + (setf (%vector-raw-bits sequence words) + (shift-towards-start value (- bits))))) + sequence))) ;;;; %BYTE-BLT @@ -775,6 +703,8 @@ ;;; position of the last set bit. We can't use this second method when ;;; the high order bit is bit 31 because shifting by 32 doesn't work ;;; too well. +;;; This is used only for ppc + sparc. +;;; FIXME: ppc64 should have a UB64-STRENGTH-REDUCE- (defun ub32-strength-reduce-constant-multiply (arg num) (declare (type (unsigned-byte 32) num)) (let ((adds 0) (shifts 0) @@ -838,3 +768,19 @@ ;; because %PRIMITIVE is not generally fopcompilable. (sb-c:define-source-transform make-unbound-marker () `(sb-sys:%primitive make-unbound-marker)) + +(deftransform (cas symbol-value) ((old new symbol)) + (let ((cname (and (constant-lvar-p symbol) (lvar-value symbol)))) + (case (and cname (info :variable :kind cname)) + ((:special :global) + (let ((type (info :variable :type cname))) + `(truly-the ,type + (%compare-and-swap-symbol-value ',cname old (the ,type new))))) + (t + `(progn + (about-to-modify-symbol-value symbol 'compare-and-swap new) + (%compare-and-swap-symbol-value symbol old new)))))) + +(deftransform (cas svref) ((old new vector index)) + '(let ((v (the simple-vector vector))) + (%compare-and-swap-svref v (check-bound v (length v) index) old new))) diff -Nru sbcl-2.1.1/src/compiler/generic/vm-type.lisp sbcl-2.1.11/src/compiler/generic/vm-type.lisp --- sbcl-2.1.1/src/compiler/generic/vm-type.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-type.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -71,14 +71,20 @@ ;;;; hooks into the type system +;;; Typically the use for UNBOXED-ARRAY is with foreign APIs where we want to +;;; require that the array being passed has byte nature, and is not SIMPLE-VECTOR. +;;; But (VECTOR NIL) contains no data, so surely there is no reason for +;;; passing it to foreign code. (sb-xc:deftype unboxed-array (&optional dims) (cons 'or (mapcar (lambda (type) `(array ,type ,dims)) - '#.(delete t (map 'list 'sb-vm:saetp-specifier - sb-vm:*specialized-array-element-type-properties*))))) + '#.(delete-if (lambda (x) (member x '(nil t))) + (map 'list 'sb-vm:saetp-specifier + sb-vm:*specialized-array-element-type-properties*))))) (sb-xc:deftype simple-unboxed-array (&optional dims) (cons 'or (mapcar (lambda (type) `(simple-array ,type ,dims)) - '#.(delete t (map 'list 'sb-vm:saetp-specifier - sb-vm:*specialized-array-element-type-properties*))))) + '#.(delete-if (lambda (x) (member x '(nil t))) + (map 'list 'sb-vm:saetp-specifier + sb-vm:*specialized-array-element-type-properties*))))) (sb-xc:deftype complex-vector (&optional element-type length) `(and (vector ,element-type ,length) (not simple-array))) diff -Nru sbcl-2.1.1/src/compiler/generic/vm-typetran.lisp sbcl-2.1.11/src/compiler/generic/vm-typetran.lisp --- sbcl-2.1.1/src/compiler/generic/vm-typetran.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/generic/vm-typetran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -126,7 +126,7 @@ (defglobal *backend-type-predicates-grouped* (let (plist) (loop for (type . pred) in *backend-type-predicates* - for class = (#-sb-xc-host %instance-layout + for class = (#-sb-xc-host %instance-wrapper #+sb-xc-host type-of type) do (push type (getf plist class)) @@ -155,7 +155,7 @@ (declare (inline vector-getf)) (let ((group (truly-the (or simple-vector null) (vector-getf *backend-type-predicates-grouped* - (#-sb-xc-host %instance-layout + (#-sb-xc-host %instance-wrapper #+sb-xc-host type-of type) #'eq)))) (when group @@ -163,3 +163,26 @@ (sb-kernel::ctype-eq-comparable type)) (vector-getf (truly-the simple-vector group) type #'eq 1) (vector-getf (truly-the simple-vector group) type #'type= 1)))))) + +(defglobal *backend-union-type-predicates* + (let ((unions (sort + (loop for (type . pred) in *backend-type-predicates* + when (union-type-p type) + collect (cons type pred)) + #'> + :key (lambda (x) + (length (union-type-types (car x))))))) + (coerce (loop for (key . value) in unions + collect key + collect value) + 'vector))) +(declaim (simple-vector *backend-union-type-predicates*)) + +(defun split-union-type-tests (type) + (let ((predicates *backend-union-type-predicates*) + (types (union-type-types type))) + (loop for x below (length predicates) by 2 + for union-types = (union-type-types (aref predicates x)) + when (subsetp union-types types :test #'type=) + return (values (aref predicates (1+ x)) + (set-difference types union-types))))) diff -Nru sbcl-2.1.1/src/compiler/globaldb.lisp sbcl-2.1.11/src/compiler/globaldb.lisp --- sbcl-2.1.1/src/compiler/globaldb.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/globaldb.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -51,9 +51,9 @@ ;;; sources partway through bootstrapping, tch tch, overwriting its ;;; version with our version would be unlikely to help, because that ;;; would make the cross-compiler very confused.) -(defun !register-meta-info (metainfo) +(defun register-meta-info (metainfo) (let* ((name (meta-info-kind metainfo)) - (list (!get-meta-infos name))) + (list (get-meta-infos name))) (set-info-value name +info-metainfo-type-num+ (cond ((not list) metainfo) ; unique, just store it ((listp list) (cons metainfo list)) ; prepend to the list @@ -67,26 +67,11 @@ (return-from !%define-info-type it)) ; do nothing (let ((id (or id (position nil *info-types* :start 1) (error "no more INFO type numbers available")))) - (!register-meta-info + (register-meta-info (setf (aref *info-types* id) (!make-meta-info id category kind type-spec type-checker validate-function default))))) -#-sb-xc -(setf (get '!%define-info-type :sb-cold-funcall-handler/for-effect) - (lambda (category kind type-spec checker validator default id) - ;; The SB-FASL: symbols are poor style, but the lesser evil. - ;; If exported, then they'll stick around in the target image. - ;; Perhaps SB-COLD should re-export some of these. - (sb-fasl::cold-svset - (sb-fasl::cold-symbol-value '*info-types*) - id - (sb-fasl::write-slots - (sb-fasl::allocate-struct-of-type 'meta-info) - 'meta-info ; pass the type name in lieu of layout - :category category :kind kind :type-spec type-spec - :type-checker checker :validate-function validator - :default default :number id)))) ;;;; info types, and type numbers, part II: what's ;;;; needed only at compile time, not at run time @@ -115,16 +100,17 @@ ;; There was formerly a remark that (COPY-TREE TYPE-SPEC) ensures repeatable ;; fasls. That's not true now, probably never was. A compiler is permitted to ;; coalesce EQUAL quoted lists and there's no defense against it, so why try? - `(!%define-info-type - ,category ,kind ',type-spec - ,(if (eq type-spec 't) - '#'identity - `(named-lambda "check-type" (x) (the ,type-spec x))) - ,validate-function ,default - ;; Rationale for hardcoding here is explained at INFO-VECTOR-FDEFN. - ,(or (and (eq category :function) (eq kind :definition) - +fdefn-info-num+) - #+sb-xc (meta-info-number (meta-info category kind))))) + `(!cold-init-forms + (!%define-info-type + ,category ,kind ',type-spec + ,(if (eq type-spec 't) + '#'identity + `(named-lambda "check-type" (x) (the ,type-spec x))) + ,validate-function ,default + ;; Rationale for hardcoding here is explained at PACKED-INFO-FDEFN. + ,(or (and (eq category :function) (eq kind :definition) + +fdefn-info-num+) + #+sb-xc (meta-info-number (meta-info category kind)))))) ;; It's an external symbol of SB-INT so wouldn't be removed automatically (push '("SB-INT" define-info-type) *!removable-symbols*) @@ -191,24 +177,12 @@ (info-puthash *info-environment* name #'clear-hairy))) (not (null new)))) -;;;; *INFO-ENVIRONMENT* - -(defun !globaldb-cold-init () - ;; Genesis writes the *INFO-TYPES* array, but setting up the mapping - ;; from keyword-pair to object is deferred until cold-init. - (dovector (x (the simple-vector *info-types*)) - (when x (!register-meta-info x))) - #-sb-xc-host - (let ((h (make-info-hashtable))) - (setf (sb-thread:mutex-name (info-env-mutex h)) "globaldb") - (setq *info-environment* h))) - ;;;; GET-INFO-VALUE ;;; If non-nil, *GLOBALDB-OBSERVER*'s CAR is a bitmask over info numbers ;;; for which you'd like to call the function in the CDR whenever info ;;; of that number is queried. -(defparameter *globaldb-observer* nil) +(defvar *globaldb-observer* nil) (declaim (type (or (cons (unsigned-byte #.(ash 1 info-number-bits)) function) null) *globaldb-observer*)) #-sb-xc-host (declaim (always-bound *globaldb-observer*)) @@ -230,18 +204,18 @@ (hookp (and (and hook (not (eql 0 (car hook))) (logbitp info-number (car hook)))))) - (multiple-value-bind (vector aux-key) + (multiple-value-bind (packed-info aux-key) (let ((name (uncross name))) (with-globaldb-name (key1 key2) name ;; In the :simple branch, KEY1 is no doubt a symbol, ;; but constraint propagation isn't informing the compiler here. - :simple (values (symbol-info-vector (truly-the symbol key1)) key2) + :simple (values (symbol-dbinfo (truly-the symbol key1)) key2) :hairy (values (info-gethash name *info-environment*) +no-auxiliary-key+))) - (when vector - (let ((index (packed-info-value-index vector aux-key info-number))) + (when packed-info + (let ((index (packed-info-value-index packed-info aux-key info-number))) (when index - (let ((answer (svref vector index))) + (let ((answer (%info-ref packed-info index))) (when hookp (funcall (truly-the function (cdr hook)) name info-number answer t)) @@ -252,6 +226,7 @@ (funcall (truly-the function (cdr hook)) name info-number answer nil)) (values answer nil)))) +(!begin-collecting-cold-init-forms) ;;;; ":FUNCTION" subsection - Data pertaining to globally known functions. (define-info-type (:function :definition) :type-spec #-sb-xc-host (or fdefn null) #+sb-xc-host t) @@ -281,12 +256,28 @@ (define-info-type (:function :deprecated) :type-spec (or null deprecation-info)) -;;; Why are these here? It seems like the wrong place. +;;; FIXME: Why are these here? It seems like the wrong place. (declaim (ftype (sfunction (t &optional t symbol) ctype) specifier-type) (ftype (sfunction (t) ctype) ctype-of sb-kernel::ctype-of-array)) +;;; The parsed or unparsed type for this function, or the symbol :GENERIC-FUNCTION. +;;; Ordinarily a parsed type is stored. Only if the parsed type contains +;;; an unknown type will the original specifier be stored; we attempt to reparse +;;; on each lookup, in the hope that the type becomes known at some point. +;;; If :GENERIC-FUNCTION, the info is recomputed from methods at the time of lookup +;;; and stored back. Method redefinition resets the value to :GENERIC-FUNCTION. +(define-info-type (:function :type) + :type-spec (or ctype (cons (eql function)) (member :generic-function)) + :default (lambda (name) + (declare (ignorable name)) + #+sb-xc-host (specifier-type 'function) + #-sb-xc-host (sb-impl::ftype-from-fdefn name))) + ;;; the ASSUMED-TYPE for this function, if we have to infer the type ;;; due to not having a declaration or definition +;;; FIXME: It may be better to have this and/or :TYPE stored in a single +;;; property as either (:known . #) or (:assumed . #) +;;; rather than using two different properties. Do we ever use *both* ? (define-info-type (:function :assumed-type) ;; FIXME: The type-spec really should be ;; (or approximate-fun-type null)). @@ -324,7 +315,7 @@ ;;; If only (B) is stored, then this is a DXABLE-ARGS. ;;; If both, this is an INLINING-DATA. (define-info-type (:function :inlining-data) - :type-spec (or list sb-c::dxable-args sb-c::inlining-data)) + :type-spec (or list sb-c::dxable-args sb-c::inlining-data)) ;;; This specifies whether this function may be expanded inline. If ;;; null, we don't care. @@ -336,6 +327,22 @@ ;;; through some kind of transformation but were not. (define-info-type (:function :emitted-full-calls) :type-spec list) +;; Return the number of calls to NAME that IR2 emitted as full calls, +;; not counting calls via #'F that went untracked. +;; Return 0 if the answer is nonzero but a warning was already signaled +;; about any full calls were emitted. This return convention satisfies the +;; intended use of this statistic - to decide whether to generate a warning +;; about failure to inline NAME, which is shown at most once per name +;; to avoid unleashing a flood of identical warnings. +(defun emitted-full-call-count (name) + (let ((status (car (info :function :emitted-full-calls name)))) + (and (integerp status) + ;; Bit 0 tells whether any call was NOT in the presence of + ;; a 'notinline' declaration, thus eligible to be inline. + ;; Bit 1 tells whether any warning was emitted yet. + (= (logand status 3) #b01) + (ash status -2)))) ; the call count as tracked by IR2 + ;;; a macro-like function which transforms a call to this function ;;; into some other Lisp form. This expansion is inhibited if inline ;;; expansion is inhibited. @@ -478,6 +485,13 @@ ;;; The classoid-cell for this type (define-info-type (:type :classoid-cell) :type-spec t) +;;; wrapper for this type being used by the compiler +(define-info-type (:type :compiler-layout) + :type-spec (or wrapper null) + :default (lambda (name) + (let ((class (find-classoid name nil))) + (and class (classoid-wrapper class))))) + ;;; DEFTYPE lambda-list ;; FIXME: remove this after making swank-fancy-inspector not use it. (define-info-type (:type :lambda-list) :type-spec t) @@ -530,9 +544,7 @@ :type-spec (or null sb-alien-internals:alien-type)) ;;;; ":SETF" subsection - Data pertaining to expansion of the omnipotent macro. -(define-info-type (:setf :documentation) :type-spec (or string null)) -(define-info-type (:setf :expander) - :type-spec (or symbol function (cons integer function) null)) +(define-info-type (:setf :expander) :type-spec (or function list)) ;;;; ":CAS" subsection - Like SETF but there are no "inverses", just expanders (define-info-type (:cas :expander) :type-spec (or function null)) @@ -558,9 +570,20 @@ (define-info-type (:source-location :declaration) :type-spec t) (define-info-type (:source-location :alien-type) :type-spec t) +(!defun-from-collected-cold-init-forms !info-type-cold-init) + +#-sb-xc-host +(defun !globaldb-cold-init () + (let ((h (make-info-hashtable))) + (setf (sb-thread:mutex-name (info-env-mutex h)) "globaldb") + (setq *info-environment* h)) + (setq *globaldb-observer* nil) + (setq *info-types* (make-array (ash 1 info-number-bits) :initial-element nil)) + (!info-type-cold-init)) + ;; This is for the SB-INTROSPECT contrib module, and debugging. (defun call-with-each-info (function symbol) - (awhen (symbol-info-vector symbol) + (awhen (symbol-dbinfo symbol) (%call-with-each-info function it symbol))) ;; This is for debugging at the REPL. diff -Nru sbcl-2.1.1/src/compiler/gtn.lisp sbcl-2.1.11/src/compiler/gtn.lisp --- sbcl-2.1.1/src/compiler/gtn.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/gtn.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -18,9 +18,15 @@ ;;; passing locations and return conventions and TNs for local variables. (defun gtn-analyze (component) (setf (component-info component) (make-ir2-component)) - (let ((funs (component-lambdas component))) + (let ((funs (component-lambdas component)) + #+fp-and-pc-standard-save + (old-fp (make-old-fp-save-location)) + #+fp-and-pc-standard-save + (old-pc (make-return-pc-save-location))) (dolist (fun funs) - (assign-ir2-physenv fun) + (assign-ir2-environment fun + #+fp-and-pc-standard-save old-fp + #+fp-and-pc-standard-save old-pc) (assign-ir2-nlx-info fun) (assign-lambda-var-tns fun nil) (dolist (let (lambda-lets fun)) @@ -29,7 +35,7 @@ (values)) ;;; We have to allocate the home TNs for variables before we can call -;;; ASSIGN-IR2-PHYSENV so that we can close over TNs that haven't +;;; ASSIGN-IR2-ENVIRONMENT so that we can close over TNs that haven't ;;; had their home environment assigned yet. Here we evaluate the ;;; DEBUG-INFO/SPEED tradeoff to determine how variables are ;;; allocated. If SPEED is 3, then all variables are subject to @@ -59,29 +65,36 @@ (not (lambda-var-explicit-value-cell var))) ;; Force closed-over indirect LAMBDA-VARs without explicit ;; VALUE-CELLs to the stack, and make sure that they are - ;; live over the dynamic contour of the physenv. + ;; live over the dynamic contour of the environment. (setf (tn-sc res) (if ptype-info (second ptype-info) (sc-or-lose 'sb-vm::control-stack))) - (physenv-live-tn res (lambda-physenv fun))) + (environment-live-tn res (lambda-environment fun))) (debug-variable-p - (physenv-debug-live-tn res (lambda-physenv fun)))) + ;; If it's a constant it may end up being never read, + ;; replaced by COERCE-FROM-CONSTANT. + ;; Yet it might get saved on the stack, but since it's + ;; never read no stack space is allocated for it in the + ;; callee frame. + (unless (type-singleton-p (leaf-type var)) + (environment-debug-live-tn res (lambda-environment fun))))) (setf (tn-leaf res) var) (setf (tn-type res) (leaf-type var)) (setf (leaf-info var) res)))) (values)) -;;; Give CLAMBDA an IR2-PHYSENV structure. (And in order to +;;; Give CLAMBDA an IR2-ENVIRONMENT structure. (And in order to ;;; properly initialize the new structure, we make the TNs which hold ;;; environment values and the old-FP/return-PC.) -(defun assign-ir2-physenv (clambda) +(defun assign-ir2-environment (clambda #+fp-and-pc-standard-save old-fp + #+fp-and-pc-standard-save old-pc) (declare (type clambda clambda)) - (let* ((lambda-physenv (lambda-physenv clambda)) + (let* ((lambda-environment (lambda-environment clambda)) (indirect-fp-tns) - (ir2-physenv-alist - (loop for thing in (physenv-closure lambda-physenv) + (ir2-environment-alist + (loop for thing in (environment-closure lambda-environment) collect (cons thing (etypecase thing @@ -90,11 +103,11 @@ (make-normal-tn (primitive-type (leaf-type thing)))) ((not (lambda-var-explicit-value-cell thing)) - (let ((physenv (lambda-physenv (lambda-var-home thing)))) - (or (getf indirect-fp-tns physenv) + (let ((env (lambda-environment (lambda-var-home thing)))) + (or (getf indirect-fp-tns env) (let ((tn (make-normal-tn *backend-t-primitive-type*))) (push tn indirect-fp-tns) - (push physenv indirect-fp-tns) + (push env indirect-fp-tns) tn)))) (t (make-normal-tn *backend-t-primitive-type*)))) @@ -102,15 +115,27 @@ (make-normal-tn *backend-t-primitive-type*)) (clambda (make-normal-tn *backend-t-primitive-type*))))))) - (let ((res (make-ir2-physenv - :closure ir2-physenv-alist - :return-pc-pass (make-return-pc-passing-location - (xep-p clambda))))) - (setf (physenv-info lambda-physenv) res) - (setf (ir2-physenv-old-fp res) - (make-old-fp-save-location lambda-physenv)) - (setf (ir2-physenv-return-pc res) - (make-return-pc-save-location lambda-physenv)))) + (let ((res (make-ir2-environment + :closure ir2-environment-alist + :return-pc-pass #+fp-and-pc-standard-save + old-pc + #-fp-and-pc-standard-save + (make-return-pc-passing-location (xep-p clambda))))) + (setf (environment-info lambda-environment) res) + (setf (ir2-environment-old-fp res) + #-fp-and-pc-standard-save + (make-old-fp-save-location lambda-environment) + #+fp-and-pc-standard-save + old-fp) + (setf (ir2-environment-return-pc res) + #-fp-and-pc-standard-save + (make-return-pc-save-location lambda-environment) + #+fp-and-pc-standard-save + old-pc) + #+fp-and-pc-standard-save + (progn + (push old-fp (ir2-environment-live-tns (environment-info lambda-environment))) + (push old-pc (ir2-environment-live-tns (environment-info lambda-environment)))))) (values)) @@ -226,8 +251,8 @@ ;;; isn't live afterwards. (defun assign-ir2-nlx-info (fun) (declare (type clambda fun)) - (let ((physenv (lambda-physenv fun))) - (dolist (nlx (physenv-nlx-info physenv)) + (let ((env (lambda-environment fun))) + (dolist (nlx (environment-nlx-info env)) (setf (nlx-info-info nlx) (make-ir2-nlx-info :home (when (member (cleanup-kind (nlx-info-cleanup nlx)) @@ -237,8 +262,8 @@ (make-stack-pointer-tn))) :save-sp (unless (eq (cleanup-kind (nlx-info-cleanup nlx)) :unwind-protect) - (make-nlx-sp-tn physenv)) - :block-tn (physenv-live-tn + (make-nlx-sp-tn env)) + :block-tn (environment-live-tn (make-normal-tn (primitive-type-or-lose (ecase (cleanup-kind (nlx-info-cleanup nlx)) @@ -246,5 +271,5 @@ 'catch-block) ((:unwind-protect :block :tagbody) 'unwind-block)))) - physenv))))) + env))))) (values)) diff -Nru sbcl-2.1.1/src/compiler/info-functions.lisp sbcl-2.1.11/src/compiler/info-functions.lisp --- sbcl-2.1.1/src/compiler/info-functions.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/info-functions.lisp 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -;;;; miscellaneous functions which use INFO -;;;; -;;;; (In CMU CL, these were in globaldb.lisp. They've been moved here -;;;; because references to INFO can't be compiled correctly until -;;;; globaldb initialization is complete, and the SBCL technique for -;;;; initializing the global database in the cross-compiler isn't -;;;; completed until load time.) - -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. -;;;; -;;;; This software is derived from the CMU CL system, which was -;;;; written at Carnegie Mellon University and released into the -;;;; public domain. The software is in the public domain and is -;;;; provided with absolutely no warranty. See the COPYING and CREDITS -;;;; files for more information. - -(in-package "SB-C") - -;;;; internal utilities defined in terms of INFO - -(defun check-variable-name (name &key - (context "local variable") - (signal-via #'compiler-error)) - (unless (legal-variable-name-p name) - (funcall signal-via "~@<~S~[~; is a keyword and~; is not a symbol and~ - ~] cannot be used as a ~A.~@:>" - name - (typecase name - (null 0) - (keyword 1) - (t 2)) - context)) - name) - -;;; Check that NAME is a valid function name, returning the name if -;;; OK, and signalling an error if not. In addition to checking for -;;; basic well-formedness, we also check that symbol names are not NIL -;;; or the name of a special form. -(defun check-fun-name (name) - (typecase name - (list - (unless (legal-fun-name-p name) - (compiler-error "~@" name))) - (symbol - (when (eq (info :function :kind name) :special-form) - (compiler-error "~@" - name))) - (t - (compiler-error "~@" name))) - name) - -;;; Record a new function definition, and check its legality. -(defun proclaim-as-fun-name (name) - - ;; legal name? - (check-fun-name name) - - ;; KLUDGE: This can happen when eg. compiling a NAMED-LAMBDA, and isn't - ;; guarded against elsewhere -- so we want to assert package locks here. The - ;; reason we do it only when stomping on existing stuff is because we want - ;; to keep - ;; (WITHOUT-PACKAGE-LOCKS (DEFUN LOCKED:FOO ...)) - ;; viable, which requires no compile-time violations in the harmless cases. - (with-single-package-locked-error () - (flet ((assert-it () - (assert-symbol-home-package-unlocked name "proclaiming ~S as a function"))) - - (let ((kind (info :function :kind name))) - ;; scrubbing old data I: possible collision with a macro - (when (and (fboundp name) (eq :macro kind)) - (assert-it) - (compiler-style-warn "~S was previously defined as a macro." name) - (setf (info :function :where-from name) :assumed) - (clear-info :function :macro-function name)) - - (unless (eq :function kind) - (assert-it) - ;; There's no reason to store (:FUNCTION :KIND) for names which - ;; could only be of kind :FUNCTION if anything. - (unless (pcl-methodfn-name-p name) - (setf (info :function :kind name) :function)))))) - - ;; scrubbing old data II: dangling forward references - ;; - ;; (This could happen if someone executes PROCLAIM FTYPE at - ;; macroexpansion time, which is bad style, or at compile time, e.g. - ;; in EVAL-WHEN (:COMPILE) inside something like DEFSTRUCT, in which - ;; case it's reasonable style. Either way, NAME is no longer a free - ;; function.) - (when (boundp '*ir1-namespace*) ; when compiling - (unless (block-compile *compilation*) - (remhash name (free-funs *ir1-namespace*)))) - - (values)) - -;;; This is called to do something about SETF functions that overlap -;;; with SETF macros. Perhaps we should interact with the user to see -;;; whether the macro should be blown away, but for now just give a -;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we -;;; can't assume that they aren't just naming a function (SETF FOO) -;;; for the heck of it. NAME is already known to be well-formed. -(defun warn-if-setf-macro (name) - ;; Never warn about this situation when running the cross-compiler. - ;; SBCL provides expanders/inverses *and* functions for most SETFable things - ;; even when CLHS does not specifically state that #'(SETF x) exists. - #+sb-xc-host (declare (ignore name)) - #-sb-xc-host - (let ((stem (second name))) - (when (info :setf :expander stem) - (compiler-style-warn - "defining function ~S when ~S already has a SETF macro" - name stem))) - (values)) - -;;; Make NAME no longer be a function name: clear everything back to -;;; the default. -(defun undefine-fun-name (name) - (when name - (macrolet ((frob (&rest types) - `(clear-info-values - name ',(mapcar (lambda (x) - (meta-info-number (meta-info :function x))) - types)))) - ;; Note that this does not clear the :DEFINITION. - ;; That's correct, because if we lose the association between a - ;; symbol and its # object, it could lead to creation of - ;; a non-unique # for a name. - (frob :info - :type ; Hmm. What if it was proclaimed- shouldn't it stay? - :where-from ; Ditto. - :inlinep - :kind - :macro-function - :inlining-data - :source-transform - :assumed-type))) - (values)) - -;;; part of what happens with DEFUN, also with some PCL stuff: Make -;;; NAME known to be a function definition. -(defun become-defined-fun-name (name) - (proclaim-as-fun-name name) - (when (eq (info :function :where-from name) :assumed) - (setf (info :function :where-from name) :defined) - (if (info :function :assumed-type name) - (clear-info :function :assumed-type name)))) - -;;; Unpack (INFO :FUNCTION :INLINING-DATA FUN-NAME). If an explicit expansion -;;; is not stored but FUN-NAME is a structure constructor, reconstitute the -;;; expansion from the defstruct description. Secondary value is T if the expansion -;;; was explicit. See SAVE-INLINE-EXPANSION-P for why we care. -;;; (Essentially, once stored then always stored, lest inconsistency result) -;;; If we have just a DXABLE-ARGS, or nothing at all, return NIL and NIL. -;;; If called on a string or anything that is not a function designator, -;;; return NIL and NIL. -(declaim (ftype (sfunction (t) (values list boolean)) - fun-name-inline-expansion)) -(defun fun-name-inline-expansion (fun-name) - (multiple-value-bind (answer winp) (info :function :inlining-data fun-name) - (typecase answer - ;; an INLINING-DATA is a DXABLE-ARGS, so test it first - (inlining-data (setq answer (inlining-data-expansion answer))) - (dxable-args (setq answer nil winp nil))) - (when (and (not winp) (symbolp fun-name)) - (let ((info (info :function :source-transform fun-name))) - (when (typep info '(cons defstruct-description (eql :constructor))) - (let* ((dd (car info)) (spec (assq fun-name (dd-constructors dd)))) - (aver spec) - (setq answer `(lambda ,@(structure-ctor-lambda-parts dd (cdr spec)))))))) - (values answer winp))) -(defun fun-name-dx-args (fun-name) - (let ((answer (info :function :inlining-data fun-name))) - (when (typep answer 'dxable-args) - (dxable-args-list answer)))) - -;;;; ANSI Common Lisp functions which are defined in terms of the info -;;;; database - -(defun macro-function (symbol &optional env) - "If SYMBOL names a macro in ENV, returns the expansion function, -else returns NIL. If ENV is unspecified or NIL, use the global environment -only." - ;; local function definitions (ordinary) can shadow a global macro - (typecase env - #+(and sb-fasteval (not sb-xc-host)) - (sb-interpreter:basic-env - (multiple-value-bind (kind def) - (sb-interpreter:find-lexical-fun env symbol) - (when def - (return-from macro-function (when (eq kind :macro) def))))) - (lexenv - (let ((def (cdr (assoc symbol (lexenv-funs env))))) - (when def - (return-from macro-function - (when (typep def '(cons (eql macro))) (cdr def))))))) - (values (info :function :macro-function symbol))) - -(defun (setf macro-function) (function symbol &optional environment) - (declare (symbol symbol) (type function function)) - (when environment - ;; Note: Technically there could be an ENV optional argument to SETF - ;; MACRO-FUNCTION, but since ANSI says that the consequences of - ;; supplying a non-nil one are undefined, we don't allow it. - ;; (Thus our implementation of this unspecified behavior is to - ;; complain. SInce the behavior is unspecified, this is conforming.:-) - (error "Non-NIL environment argument in SETF of MACRO-FUNCTION ~S: ~S" - symbol environment)) - (when (eq (info :function :kind symbol) :special-form) - (error "~S names a special form." symbol)) - (with-single-package-locked-error (:symbol symbol "setting the macro-function of ~S") - (clear-info :function :type symbol) - (setf (info :function :kind symbol) :macro) - (setf (info :function :macro-function symbol) function) - #-sb-xc-host (install-guard-function symbol `(:macro ,symbol))) - function) - -(defun compiler-macro-function (name &optional env) - "If NAME names a compiler-macro in ENV, return the expansion function, else -return NIL. Can be set with SETF when ENV is NIL." - (legal-fun-name-or-type-error name) - ;; CLHS 3.2.2.1: Creating a lexical binding for the function name - ;; not only creates a new local function or macro definition, but - ;; also shadows[2] the compiler macro. - (unless (fun-locally-defined-p name env) - ;; Note: CMU CL used to return NIL here when a NOTINLINE - ;; declaration was in force. That's fairly logical, given the - ;; specified effect of NOTINLINE declarations on compiler-macro - ;; expansion. However, (1) it doesn't seem to be consistent with - ;; the ANSI spec for COMPILER-MACRO-FUNCTION, and (2) it would - ;; give surprising behavior for (SETF (COMPILER-MACRO-FUNCTION - ;; FOO) ...) in the presence of a (PROCLAIM '(NOTINLINE FOO)). So - ;; we don't do it. - (values (info :function :compiler-macro-function name)))) - -;;; FIXME: we don't generate redefinition warnings for these. -(defun (setf compiler-macro-function) (function name &optional env) - (declare (type (or symbol list) name) - (type (or function null) function)) - (when env - ;; ANSI says this operation is undefined. - (error "can't SETF COMPILER-MACRO-FUNCTION when ENV is non-NIL")) - (when (eq (info :function :kind name) :special-form) - (error "~S names a special form." name)) - (with-single-package-locked-error - (:symbol name "setting the compiler-macro-function of ~A") - (setf (info :function :compiler-macro-function name) function) - function)) - -;;;; a subset of DOCUMENTATION functionality for bootstrapping - -;; Return the number of calls to NAME that IR2 emitted as full calls, -;; not counting calls via #'F that went untracked. -;; Return 0 if the answer is nonzero but a warning was already signaled -;; about any full calls were emitted. This return convention satisfies the -;; intended use of this statistic - to decide whether to generate a warning -;; about failure to inline NAME, which is shown at most once per name -;; to avoid unleashing a flood of identical warnings. -(defun emitted-full-call-count (name) - (let ((status (car (info :function :emitted-full-calls name)))) - (and (integerp status) - ;; Bit 0 tells whether any call was NOT in the presence of - ;; a 'notinline' declaration, thus eligible to be inline. - ;; Bit 1 tells whether any warning was emitted yet. - (= (logand status 3) #b01) - (ash status -2)))) ; the call count as tracked by IR2 diff -Nru sbcl-2.1.1/src/compiler/info-vector.lisp sbcl-2.1.11/src/compiler/info-vector.lisp --- sbcl-2.1.1/src/compiler/info-vector.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/info-vector.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -44,31 +44,31 @@ ;;; * Names which are lists of length other than 2, or improper lists, ;;; or whose elements are not both symbols, are disqualified. -;;; Packed vector layout -;;; -------------------- +;;; Packed format +;;; ------------- ;;; Because the keys to the inner lists are integers in the range 0 to 63, ;;; either 5 or 10 keys will fit into a fixnum depending on word size. ;;; This permits one memory read to retrieve a collection of keys. In packed ;;; format, an ordered set of keys ("fields") is called a "descriptor". ;;; -;;; Descriptors are stored from element 0 upward in the packed vector, -;;; and data are indexed downward from the last element of the vector. +;;; Descriptors are stored from element 0 upward in the packed-info, +;;; and data are indexed downward from the last element. ;;; -;;; #(descriptor0 descriptor1 ... descriptorN valueN ... value1 value0) +;;; [descriptor0 descriptor1 ... descriptorN valueN ... value1 value0] ;;; -;;; e.g. The field at absolute index 3 - vector element 0, bit position 18 - +;;; e.g. The field at absolute index 3 (physical element 0, bit position 18) ;;; will find its data at index (- END 3). In this manner, it doesn't matter ;;; how many more descriptors exist. ;;; A "group" comprises all the info for a particular Name, and its list ;;; of types may may span descriptors, though rarely. ;;; An "auxiliary key" is the first element of a 2-list Name. It is interposed -;;; within the data portion of the vector after the preceding info group. +;;; within the data portion of the packed-info after the preceding info group. ;;; Descriptors are self-delimiting in that the first field in a group ;;; indicates the number of additional fields in the group. -;;; Unpacked vector layout -;;; ---------------------- +;;; Unpacked format +;;; --------------- ;;; This representation is used transiently during insertion/deletion. ;;; It is a concatenation of plists as a vector, interposing at the splice ;;; points the auxiliary key for the group, except for the root name which @@ -85,10 +85,14 @@ ;;; One can envision that the first info group stores its auxiliary key ;;; at vector index -1 when thinking about the correctness of algorithms ;;; that process unpacked info-vectors. -;;; See !TEST-PACKIFY-INFOS for examples of each format. +;;; See TEST-PACKIFY-INFOS for examples of each format. ;;;;; Some stuff moved from 'globaldb.lisp': +;;; The structure constructor is never called +(sb-xc:defstruct (packed-info (:predicate nil) (:constructor nil) (:copier nil)) + cells) +;;(declaim (freeze-type packed-info)) ; crashes? (defconstant info-num-mask (ldb (byte info-number-bits 0) -1)) ; #b111111 ;; Using 6 bits per packed field, 5 infos can be described in a 30-bit fixnum, @@ -101,20 +105,25 @@ (deftype info-descriptor () `(signed-byte ,sb-vm:n-fixnum-bits)) ;; An empty info-vector. Its 0th field describes that there are no more fields. -(defconstant-eqx +nil-packed-infos+ #(0) #'equalp) +(defglobal +nil-packed-infos+ + (let ((v (make-packed-info 1))) + (setf (%info-ref v 0) 0) + v)) ;; FDEFINITIONs have an info-number that admits slightly clever logic -;; for INFO-VECTOR-FDEFN. Do not change this constant without +;; for PACKED-INFO-FDEFN. Do not change this constant without ;; careful examination of that function. (defconstant +fdefn-info-num+ info-num-mask) ;; Extract a field from a packed info descriptor. ;; A field is either a count of info-numbers, or an info-number. (declaim (inline packed-info-field)) -(defun packed-info-field (vector desc-index field-index) +(defun packed-info-field (packed-info desc-index field-index) + ;; (declare (optimize (safety 0))) ; comment out when debugging (ldb (byte info-number-bits (* (the (mod #.+infos-per-word+) field-index) info-number-bits)) - (the info-descriptor (svref vector desc-index)))) + (the info-descriptor + (%info-ref (the packed-info packed-info) desc-index)))) ;; Compute the number of elements needed to hold unpacked VECTOR after packing. ;; This is not "compute-packed-info-size" since that could be misconstrued @@ -159,10 +168,10 @@ ;; (defun packify-infos (input &optional (end (length input))) (declare (simple-vector input)) - (let* ((output (make-array (compute-packified-info-size input end))) + (let* ((output (make-packed-info (compute-packified-info-size input end))) (i -1) ; input index: pre-increment to read the next datum (j -1) ; descriptor index: pre-increment to write - (k (length output)) ; data index: pre-decrement to write + (k (packed-info-len output)) ; data index: pre-decrement to write (field-shift 0) (word 0)) (declare (type index-or-minus-1 i j k end) @@ -174,19 +183,19 @@ (setq word (logior (make-info-descriptor val field-shift) word)) (if (< field-shift (* (1- +infos-per-word+) info-number-bits)) (incf field-shift info-number-bits) - (setf (svref output (incf j)) word field-shift 0 word 0)))) + (setf (%info-ref output (incf j)) word field-shift 0 word 0)))) ;; Truncating divide by 2: count = n-elements in the group @ 2 per entry, ;; +1 for count itself but not including its aux-key. (loop (let ((count (ash (the index (svref input (incf i))) -1))) (put-field count) ; how many infos to follow (dotimes (iter count) (put-field (svref input (incf i))) ; an info-number - (setf (svref output (decf k)) (svref input (incf i)))) ; value + (setf (%info-ref output (decf k)) (svref input (incf i)))) ; value (when (>= (incf i) end) (return)) - (setf (svref output (decf k)) (svref input i))))) ; an aux-key + (setf (%info-ref output (decf k)) (svref input i))))) ; an aux-key (unless (zerop field-shift) ; store the final descriptor word - (setf (svref output (incf j)) word)) + (setf (%info-ref output (incf j)) word)) (aver (eql (1+ j) k)) ; last descriptor must be adjacent final data cell output)) @@ -194,11 +203,11 @@ ;; returns the next field from a descriptor in INPUT-VAR, a packed vector. ;; The generator uses DESCRIPTOR-INDEX and updates it as a side-effect. ;; -(defmacro !with-packed-info-iterator ((generator input-var +(defmacro with-packed-info-iterator ((generator input-var &key descriptor-index) &body body) (with-unique-names (input word count) - `(let* ((,input (the simple-vector ,input-var)) + `(let* ((,input (the packed-info ,input-var)) (,descriptor-index -1) (,count 0) (,word 0)) @@ -208,21 +217,21 @@ (flet ((,generator () (when (zerop ,count) (incf ,descriptor-index) - (setq ,word (svref ,input ,descriptor-index) + (setq ,word (%info-ref ,input ,descriptor-index) ,count +infos-per-word+)) (prog1 (logand ,word info-num-mask) (setq ,word (ash ,word (- info-number-bits))) (decf ,count)))) ,@body)))) -;; Iterate over VECTOR, binding DATA-INDEX to the index of each aux-key in turn. +;; Iterate over PACKED-INFO, binding DATA-INDEX to the index of each aux-key in turn. ;; TOTAL-N-FIELDS is deliberately exposed to invoking code. ;; -(defmacro !do-packed-info-vector-aux-key ((vector &optional (data-index (gensym))) +(defmacro do-packed-info-aux-key ((packed-info &optional (data-index (gensym))) step-form &optional result-form) - (with-unique-names (descriptor-idx field-idx) - (once-only ((vector vector)) - `(let ((,data-index (length ,vector)) + (with-unique-names (descriptor-idx field-idx info) + `(let* ((,info ,packed-info) + (,data-index (packed-info-len ,info)) (,descriptor-idx 0) (,field-idx 0) (total-n-fields 0)) @@ -231,8 +240,7 @@ ;; Loop through the descriptors in random-access fashion. ;; Skip 1+ n-infos each time, because the 'n-infos' is itself a field ;; that is not accounted for in its own value. - (loop (let ((n (1+ (packed-info-field ,vector - ,descriptor-idx ,field-idx)))) + (loop (let ((n (1+ (packed-info-field ,info ,descriptor-idx ,field-idx)))) (incf total-n-fields n) (multiple-value-setq (,descriptor-idx ,field-idx) (floor total-n-fields +infos-per-word+)) @@ -240,36 +248,21 @@ ;; Done when the ascending index and descending index meet (unless (< ,descriptor-idx ,data-index) (return ,result-form)) - ,@(if step-form (list step-form))))))) + ,@(if step-form (list step-form)))))) -;; Return all function names that are stored in SYMBOL's info-vector. -;; As an example, (INFO-VECTOR-NAME-LIST 'SB-PCL::DIRECT-SUPERCLASSES) => -;; ((SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::READER) -;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES BOUNDP) -;; (SB-PCL::SLOT-ACCESSOR :GLOBAL SB-PCL::DIRECT-SUPERCLASSES SB-PCL::WRITER)) -(defun info-vector-name-list (symbol) - (let ((vector (symbol-info-vector symbol)) - (list)) - (when vector - (!do-packed-info-vector-aux-key (vector key-index) - (push (construct-globaldb-name (svref vector key-index) symbol) - list)) - (nconc (and (plusp (packed-info-field vector 0 0)) (list symbol)) - (nreverse list))))) - -;; Compute the number of elements needed to hold packed VECTOR after unpacking. +;; Compute the number of elements needed to hold PACKED-INFO after unpacking. ;; The unpacked size is the number of auxiliary keys plus the number of entries ;; @ 2 cells per entry, plus the number of length cells which indicate the ;; number of data cells used (including length cells but not aux key cells). ;; Equivalently, it's the number of packed fields times 2 minus 1. ;; -(defun compute-unpackified-info-size (vector) - (declare (simple-vector vector)) - (!do-packed-info-vector-aux-key (vector) () +(defun compute-unpackified-info-size (packed-info) + (declare (packed-info packed-info)) + (do-packed-info-aux-key (packed-info) () ;; off-by-one: the first info group's auxiliary key is imaginary (1- (truly-the fixnum (ash total-n-fields 1))))) -;; Convert packed INPUT vector to unpacked. +;; Convert packed INPUT to unpacked. ;; If optional OUTPUT is supplied, it is used, otherwise output is allocated. ;; For efficiency the OUTPUT should be provided as a dynamic-extent array. ;; @@ -277,19 +270,19 @@ (make-array (compute-unpackified-info-size input)) output-supplied-p)) - (declare (simple-vector input output)) - (let ((i (length input)) (j -1)) ; input index and output index respectively + (declare (type packed-info input) (simple-vector output)) + (let ((i (packed-info-len input)) (j -1)) ; input index and output index respectively (declare (type index-or-minus-1 i j)) - (!with-packed-info-iterator (next-field input :descriptor-index desc-idx) + (with-packed-info-iterator (next-field input :descriptor-index desc-idx) (loop ; over name (let ((n-infos (next-field))) ;; store the info group length, including the length cell in the length (setf (svref output (incf j)) (1+ (ash n-infos 1))) (dotimes (iter n-infos) ; over info-types (setf (svref output (incf j)) (next-field) ; type-num - (svref output (incf j)) (svref input (decf i))))) ; value + (svref output (incf j)) (%info-ref input (decf i))))) ; value (if (< desc-idx (decf i)) ; as long as the indices haven't met - (setf (svref output (incf j)) (svref input i)) ; copy next aux-key + (setf (svref output (incf j)) (%info-ref input i)) ; copy next aux-key (return (if output-supplied-p nil output))))))) ; else done ;; Return the index of the 'length' item for an info group having @@ -311,20 +304,20 @@ ((eq (svref vector (1- index)) key) (return index))))))) -;; In packed info VECTOR try to find the auxiliary key SYMBOL. +;; Try to find the auxiliary key SYMBOL in PACKED-INFO. ;; If found, return indices of its data, info descriptor word, and field. ;; If not found, the first value is NIL and the descriptor indices ;; arbitrarily point to the next available descriptor field. ;; -(defun info-find-aux-key/packed (vector symbol) +(defun info-find-aux-key/packed (packed-info symbol) ;; explicit bounds checking is done by the code below - (declare (optimize (safety 0))) - (aver (simple-vector-p vector)) - (let ((descriptor-idx 0) ; physical index to vector +; (declare (optimize (safety 0))) + (aver (typep packed-info 'packed-info)) + (let ((descriptor-idx 0) ; physical index to packed-info (field-idx 0) ; relative index within current descriptor ;; On each iteration DATA-IDX points to an aux-key cell ;; The first group's imaginary aux-key cell is past the end. - (data-idx (length (the simple-vector vector)))) + (data-idx (packed-info-len (the packed-info packed-info)))) (declare (type index descriptor-idx data-idx) (fixnum field-idx)) ; can briefly exceed +infos-per-word+ ;; Efficiently skip past N-INFOS infos. If decrementing the data index @@ -343,28 +336,28 @@ (declare (inline skip)) ;; While this could compare aux-keys with #'EQUAL, it is not obvious how ;; in general one would pick a symbol from the name as that which - ;; is delegated as the one to hold the info-vector. - (values (cond ((not (skip (packed-info-field vector 0 0))) nil) + ;; is delegated as the one to hold the packed-info + (values (cond ((not (skip (packed-info-field packed-info 0 0))) nil) ;; At least one aux key is present. - ((eq (aref vector data-idx) symbol) data-idx) ; yay + ((eq (%info-ref packed-info data-idx) symbol) data-idx) ; yay ;; aux-key order invariant allows early fail on SETF ((eq symbol 'setf) nil) (t (loop - (cond ((not (skip (packed-info-field vector descriptor-idx + (cond ((not (skip (packed-info-field packed-info descriptor-idx field-idx))) (return nil)) - ((eq (aref vector data-idx) symbol) + ((eq (%info-ref packed-info data-idx) symbol) (return data-idx)))))) descriptor-idx field-idx)))) ; can be ignored if 1st val is nil -;; Take a packed info-vector INPUT and insert (AUX-KEY,INFO-NUMBER,VALUE). +;; Take a packed-info INPUT and insert (AUX-KEY,INFO-NUMBER,VALUE). ;; Packed info-vectors are immutable. Any alteration must create a copy. ;; This is done by unpacking/repacking - it's easy enough and fairly ;; efficient since the temporary vector is stack-allocated. ;; (defun %packed-info-insert (input aux-key info-number value) - (declare (simple-vector input) (type info-number info-number)) + (declare (type packed-info input) (type info-number info-number)) (let* ((n-extra-elts ;; Test if the aux-key has been seen before or needs to be added. (if (and (not (eql aux-key +no-auxiliary-key+)) @@ -410,15 +403,15 @@ ;; exactly one descriptor for the root name, space for >= 1 more field, ;; and no aux-keys. (declaim (inline info-quickly-insertable-p)) -(defun info-quickly-insertable-p (input) - (let ((n-infos (packed-info-field input 0 0))) +(defun info-quickly-insertable-p (packed-info) + (let ((n-infos (packed-info-field packed-info 0 0))) ;; We can easily determine if the no-aux-keys constraint is satisfied, ;; because a secondary name's info occupies at least two cells, ;; one for its aux-key and >= 1 for info values. (and (< n-infos (1- +infos-per-word+)) - (eql n-infos (1- (length input)))))) + (eql n-infos (1- (packed-info-len packed-info)))))) -;; Take a packed info-vector INPUT and return a new one with INFO-NUMBER/VALUE +;; Take a packed-info INPUT and return a new one with INFO-NUMBER/VALUE ;; added for the root name. The vector must satisfy INFO-QUICKLY-INSERTABLE-P. ;; This code is separate from PACKED-INFO-INSERT to facilitate writing ;; a unit test of this logic against the complete logic. @@ -426,57 +419,57 @@ (defun quick-packed-info-insert (input info-number value) ;; Because INPUT contains 1 descriptor and its corresponding values, ;; the current length is exactly NEW-N, the new number of fields. - (let* ((descriptor (svref input 0)) - (new-n (truly-the info-number (length input))) - (new-vect (make-array (1+ new-n)))) + (let* ((descriptor (%info-ref input 0)) + (new-n (truly-the info-number (packed-info-len input))) + (output (make-packed-info (1+ new-n)))) ;; Two cases: we're either inserting info for the fdefn, or not. (cond ((eq info-number +fdefn-info-num+) ;; fdefn, if present, must remain the first packed field. ;; Replace the lowest field (the count) with +fdefn-info-num+, ;; shift everything left 6 bits, then OR in the new count. - (setf (svref new-vect 0) + (setf (%info-ref output 0) (logior (make-info-descriptor (dpb +fdefn-info-num+ (byte info-number-bits 0) descriptor) info-number-bits) new-n) ;; Packed vectors are indexed "backwards". The first ;; field's info is in the highest numbered cell. - (svref new-vect new-n) value) + (%info-ref output new-n) value) (loop for i from 1 below new-n - do (setf (svref new-vect i) (svref input i)))) + do (setf (%info-ref output i) (%info-ref input i)))) (t ;; Add a field on the high end and increment the count. - (setf (svref new-vect 0) + (setf (%info-ref output 0) (logior (make-info-descriptor info-number (* info-number-bits new-n)) (1+ descriptor)) - (svref new-vect 1) value) + (%info-ref output 1) value) ;; Slide the old data up 1 cell. (loop for i from 2 to new-n - do (setf (svref new-vect i) (svref input (1- i)))))) - new-vect)) + do (setf (%info-ref output i) (%info-ref input (1- i)))))) + output)) (declaim (maybe-inline packed-info-insert)) -(defun packed-info-insert (vector aux-key info-number newval) +(defun packed-info-insert (packed-info aux-key info-number newval) (if (and (eql aux-key +no-auxiliary-key+) - (info-quickly-insertable-p vector)) - (quick-packed-info-insert vector info-number newval) - (%packed-info-insert vector aux-key info-number newval))) + (info-quickly-insertable-p packed-info)) + (quick-packed-info-insert packed-info info-number newval) + (%packed-info-insert packed-info aux-key info-number newval))) ;; Search packed VECTOR for AUX-KEY and INFO-NUMBER, returning ;; the index of the data if found, or NIL if not found. ;; -(defun packed-info-value-index (vector aux-key type-num) - (declare (optimize (safety 0))) ; vector bounds are AVERed - (let ((data-idx (length vector)) (descriptor-idx 0) (field-idx 0)) +(defun packed-info-value-index (packed-info aux-key type-num) + ;;(declare (optimize (safetya 0))) ; bounds are AVERed + (let ((data-idx (packed-info-len packed-info)) (descriptor-idx 0) (field-idx 0)) (declare (type index descriptor-idx) (type (mod #.+infos-per-word+) field-idx)) (unless (eql aux-key +no-auxiliary-key+) (multiple-value-setq (data-idx descriptor-idx field-idx) - (info-find-aux-key/packed vector aux-key)) + (info-find-aux-key/packed packed-info aux-key)) (unless data-idx (return-from packed-info-value-index nil))) ;; Fetch a descriptor and shift out trailing bits that won't be scanned. - (let* ((descriptor (ash (the info-descriptor (aref vector descriptor-idx)) + (let* ((descriptor (ash (the info-descriptor (%info-ref packed-info descriptor-idx)) (* (- info-number-bits) field-idx))) (n-infos (logand descriptor info-num-mask)) ;; Compute n things in this descriptor after extracting one field. e.g. @@ -500,11 +493,11 @@ (incf descriptor-idx) (decf data-idx swath) (aver (< descriptor-idx data-idx)) - (setq descriptor (svref vector descriptor-idx) + (setq descriptor (%info-ref packed-info descriptor-idx) swath (min n-infos +infos-per-word+)))))) ;; Helper for CLEAR-INFO-VALUES when Name has the efficient form. -;; Given packed info-vector INPUT and auxiliary key KEY2 +;; Given packed-info INPUT and auxiliary key KEY2 ;; return a new vector in which TYPE-NUMS are absent. ;; When none of TYPE-NUMs were present to begin with, return NIL. ;; @@ -512,8 +505,8 @@ ;; clearing does not happen often enough to warrant the pre-check. ;; (defun packed-info-remove (input key2 type-nums) - (declare (simple-vector input)) - (when (or (eql (length input) (length +nil-packed-infos+)) + (declare (type packed-info input)) + (when (or (eql (packed-info-len input) #.(packed-info-len +nil-packed-infos+)) (and (not (eql key2 +no-auxiliary-key+)) (not (info-find-aux-key/packed input key2)))) (return-from packed-info-remove nil)) ; do nothing @@ -602,27 +595,27 @@ ;; Call FUNCTION with each piece of info in packed VECT using ROOT-SYMBOL ;; as the primary name. FUNCTION must accept 3 values (NAME INFO-NUMBER VALUE). -(defun %call-with-each-info (function vect root-symbol) +(defun %call-with-each-info (function packed-info root-symbol) (let ((name root-symbol) - (data-idx (length vect))) + (data-idx (packed-info-len packed-info))) (declare (type index data-idx)) - (!with-packed-info-iterator (next-field vect :descriptor-index desc-idx) + (with-packed-info-iterator (next-field packed-info :descriptor-index desc-idx) (loop ; over name (dotimes (i (next-field)) ; number of infos for this name - (funcall function name (next-field) (svref vect (decf data-idx)))) + (funcall function name (next-field) (%info-ref packed-info (decf data-idx)))) (if (< desc-idx (decf data-idx)) (setq name - (construct-globaldb-name (svref vect data-idx) root-symbol)) + (construct-globaldb-name (%info-ref packed-info data-idx) root-symbol)) (return)))))) #| Info packing example. This example has 2 auxiliary-keys: SETF and CAS. -(!test-packify-infos '(13 :XYZ 18 "nine" 28 :BAR 7 T) - '(SETF 8 NIL 17 :FGX) - '(CAS 6 :MUMBLE 2 :BAZ 47 :FOO)) +(test-packify-infos '(13 :XYZ 18 "nine" 28 :BAR 7 T) + '(SETF 8 NIL 17 :FGX) + '(CAS 6 :MUMBLE 2 :BAZ 47 :FOO)) => -#(109006134805865284 3010 :FOO :BAZ :MUMBLE CAS :FGX NIL SETF T :BAR "nine" :XYZ) +[109006134805865284 3010 :FOO :BAZ :MUMBLE CAS :FGX NIL SETF T :BAR "nine" :XYZ] (format nil "~4,'0o ~20,'0o" 3010 109006134805865284) => "5702 06032110020734221504" @@ -633,7 +626,7 @@ 2 infos for SETF auxiliary-key. type numbers: 8, 17 3 infos for CAS auxiliary-key. type numbers: 6, 2, 47 -(unpackify-infos (!test-packify-infos ...)) ; same input +(unpackify-infos (test-packify-infos ...)) ; same input => #(9 13 :XYZ 18 "nine" 28 :BAR 7 T SETF 5 8 NIL 17 :FGX CAS 7 6 :MUMBLE 2 :BAZ 47 :FOO) @@ -647,8 +640,7 @@ ;; The info for a symbol's fdefn must precede other info-numbers. ;; and SETF must be the first aux key if other aux keys are present. ;; The test function does not enforce these invariants. -#+nil ; for debugging only -(defun !test-packify-infos (&rest lists) +(defun test-packify-infos (&rest lists) (flet ((check (plist) (and (evenp (length plist)) (loop for (indicator value) on plist by #'cddr @@ -705,10 +697,9 @@ (defun update-symbol-info (symbol update-fn) ;; Never pass NIL to an update-fn. Pass the minimal info-vector instead, ;; a vector describing 0 infos and 0 auxiliary keys. - (let ((newval (funcall update-fn (or (symbol-info-vector symbol) - +nil-packed-infos+)))) + (let ((newval (funcall update-fn (or (symbol-%info symbol) +nil-packed-infos+)))) (when newval - (setf (symbol-info-vector symbol) newval)) + (setf (symbol-%info symbol) newval)) (values))) ;;; The current *INFO-ENVIRONMENT*, a structure of type INFO-HASHTABLE. @@ -779,14 +770,14 @@ (let ((name (uncross name))) ;; If the INFO-NUMBER already exists in VECT, then copy it and ;; alter one cell; otherwise unpack it, grow the vector, and repack. - (dx-flet ((augment (vect aux-key) ; VECT is a packed vector, never NIL - (declare (simple-vector vect)) + (dx-flet ((augment (packed-info aux-key) ; PACKED-INFO must not be NIL + (declare (type packed-info packed-info)) (let ((index - (packed-info-value-index vect aux-key info-number))) + (packed-info-value-index packed-info aux-key info-number))) (if (not index) - (packed-info-insert vect aux-key info-number new-value) - (let ((copy (copy-seq vect))) - (setf (svref copy index) new-value) + (packed-info-insert packed-info aux-key info-number new-value) + (let ((copy (copy-packed-info packed-info))) + (setf (%info-ref copy index) new-value) copy))))) (with-globaldb-name (key1 key2) name :simple @@ -796,8 +787,7 @@ :hairy ;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent. (dx-flet ((hairy-name (old-info) - (augment (or old-info +nil-packed-infos+) - +no-auxiliary-key+))) + (augment (or old-info +nil-packed-infos+) +no-auxiliary-key+))) (info-puthash *info-environment* name #'hairy-name))))) new-value) @@ -813,20 +803,20 @@ (when (pcl-methodfn-name-p name) (error "Can't SET-INFO-VALUE on PCL-internal function")) (let ((name (uncross name)) new-value) - (dx-flet ((augment (vect aux-key) ; VECT is a packed vector, never NIL - (declare (simple-vector vect)) + (dx-flet ((augment (packed-info aux-key) ; PACKED-INFO must not be NIL + (declare (type packed-info packed-info)) (let ((index - (packed-info-value-index vect aux-key info-number))) + (packed-info-value-index packed-info aux-key info-number))) (if (not index) (packed-info-insert - vect aux-key info-number + packed-info aux-key info-number (setq new-value (funcall new-value-fun nil nil))) - (let ((oldval (svref vect index))) + (let ((oldval (%info-ref packed-info index))) (setq new-value (funcall new-value-fun oldval t)) (if (eq new-value oldval) - vect ; return the old vector - (let ((copy (copy-seq vect))) - (setf (svref copy index) new-value) + packed-info ; return the old packed-info + (let ((copy (copy-packed-info packed-info))) + (setf (%info-ref copy index) new-value) copy))))))) (with-globaldb-name (key1 key2) name :simple @@ -855,19 +845,19 @@ (error "~D is not a legal INFO name." name)) (let ((name (uncross name)) result) - (dx-flet ((get-or-set (info-vect aux-key) + (dx-flet ((get-or-set (packed-info aux-key) (let ((index - (packed-info-value-index info-vect aux-key info-number))) + (packed-info-value-index packed-info aux-key info-number))) (cond (index - (setq result (svref info-vect index)) - nil) ; no update to info-vector + (setq result (%info-ref packed-info index)) + nil) ; no update (t ;; Update conflicts possibly for unrelated info-number ;; can force re-execution. (UNLESS result ...) tries ;; to avoid calling the thunk more than once. (unless result (setq result (funcall creation-thunk))) - (packed-info-insert info-vect aux-key info-number + (packed-info-insert packed-info aux-key info-number result)))))) (with-globaldb-name (key1 key2) name :simple @@ -877,8 +867,7 @@ :hairy ;; INFO-PUTHASH supplies NIL for OLD-INFO if NAME was absent. (dx-flet ((hairy-name (old-info) - (or (get-or-set (or old-info +nil-packed-infos+) - +no-auxiliary-key+) + (or (get-or-set (or old-info +nil-packed-infos+) +no-auxiliary-key+) ;; Return OLD-INFO to elide writeback. Unlike for ;; UPDATE-SYMBOL-INFO, NIL is not a no-op marker. old-info))) diff -Nru sbcl-2.1.1/src/compiler/ir1final.lisp sbcl-2.1.11/src/compiler/ir1final.lisp --- sbcl-2.1.1/src/compiler/ir1final.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1final.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -144,7 +144,7 @@ (delete-filter node lvar (cast-value node)))))))) (defglobal *two-arg-functions* - `((* two-arg-*) + `((* two-arg-* (,(specifier-type 'fixnum) ,(specifier-type 'fixnum)) multiply-fixnums) (+ two-arg-+) (- two-arg--) (/ two-arg-/ (,(specifier-type 'integer) ,(specifier-type 'integer)) sb-kernel::integer-/-integer) diff -Nru sbcl-2.1.1/src/compiler/ir1opt.lisp sbcl-2.1.11/src/compiler/ir1opt.lisp --- sbcl-2.1.1/src/compiler/ir1opt.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1opt.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,59 +20,54 @@ ;;; Return true for an LVAR whose sole use is a reference to a ;;; constant leaf. -(defun constant-lvar-p (thing) - (declare (type (or lvar null) thing)) - (and (lvar-p thing) - (let* ((type (lvar-type thing)) - (principal-lvar (principal-lvar thing)) - (principal-use (lvar-uses principal-lvar)) - leaf) - (or (and (ref-p principal-use) - (constant-p (setf leaf (ref-leaf principal-use))) - ;; LEAF may be a CONSTANT behind a cast that will - ;; later turn out to be of the wrong type. - ;; And ir1-transforms suffer from this because - ;; they expect LVAR-VALUE to be of a restricted type. - (or (not (lvar-reoptimize principal-lvar)) - (ctypep (constant-value leaf) type))) - ;; check for EQL types and singleton numeric types - (values (type-singleton-p type)))))) - -(defun constant-lvar-ignore-types-p (thing) - (declare (type (or lvar null) thing)) - (and (lvar-p thing) - (let* ((type (lvar-type thing)) - (principal-lvar (principal-lvar thing)) - (principal-use (lvar-uses principal-lvar))) - (or (and (ref-p principal-use) - (constant-p (ref-leaf principal-use))) - ;; check for EQL types and singleton numeric types - (values (type-singleton-p type)))))) +(defun constant-lvar-p (lvar) + (declare (type lvar lvar)) + (let* ((type (lvar-type lvar)) + (principal-lvar (principal-lvar lvar)) + (principal-use (lvar-uses principal-lvar)) + leaf) + (or (and (ref-p principal-use) + (constant-p (setf leaf (ref-leaf principal-use))) + ;; LEAF may be a CONSTANT behind a cast that will + ;; later turn out to be of the wrong type. + ;; And ir1-transforms suffer from this because + ;; they expect LVAR-VALUE to be of a restricted type. + (or (not (lvar-reoptimize principal-lvar)) + (ctypep (constant-value leaf) type))) + ;; check for EQL types and singleton numeric types + (values (type-singleton-p type))))) + +(defun constant-lvar-ignore-types-p (lvar) + (declare (type lvar lvar)) + (let ((use (principal-lvar-use lvar))) + (or (and (ref-p use) + (constant-p (ref-leaf use))) + ;; check for EQL types and singleton numeric types + (values (type-singleton-p (lvar-type lvar)))))) ;;; Are all the uses constant? -(defun constant-lvar-uses-p (thing) - (declare (type (or lvar null) thing)) - (and (lvar-p thing) - (let* ((type (lvar-type thing)) - (principal-lvar (principal-lvar thing)) - (uses (lvar-uses principal-lvar)) - leaf) - (when (consp uses) - (loop for use in uses - always - (and (ref-p use) - (constant-p (setf leaf (ref-leaf use))) - ;; LEAF may be a CONSTANT behind a cast that will - ;; later turn out to be of the wrong type. - ;; And ir1-transforms suffer from this because - ;; they expect LVAR-VALUE to be of a restricted type. - (or (not (lvar-reoptimize principal-lvar)) - (ctypep (constant-value leaf) type)))))))) +(defun constant-lvar-uses-p (lvar) + (declare (type lvar lvar)) + (let* ((type (lvar-type lvar)) + (principal-lvar (principal-lvar lvar)) + (uses (lvar-uses principal-lvar)) + leaf) + (when (consp uses) + (loop for use in uses + always + (and (ref-p use) + (constant-p (setf leaf (ref-leaf use))) + ;; LEAF may be a CONSTANT behind a cast that will + ;; later turn out to be of the wrong type. + ;; And ir1-transforms suffer from this because + ;; they expect LVAR-VALUE to be of a restricted type. + (or (not (lvar-reoptimize principal-lvar)) + (ctypep (constant-value leaf) type))))))) ;;; Return the constant value for an LVAR whose only use is a constant ;;; node. -(declaim (ftype (function (lvar) t) lvar-value)) (defun lvar-value (lvar) + (declare (type lvar lvar)) (let ((use (principal-lvar-use lvar)) (type (lvar-type lvar)) leaf) @@ -84,7 +79,17 @@ (error "~S used on non-constant LVAR ~S" 'lvar-value lvar)) value)))) +(defun lvar-value-is-nil (lvar) + (and (constant-lvar-p lvar) (null (lvar-value lvar)))) + +;;; Return true if ARG is NIL, or is a constant-lvar whose +;;; value is NIL, false otherwise. +(defun unsupplied-or-nil (arg) + (declare (type (or lvar null) arg)) + (or (not arg) (lvar-value-is-nil arg))) + (defun lvar-uses-values (lvar) + (declare (type lvar lvar)) (let ((uses (principal-lvar-use lvar))) (loop for use in uses for leaf = (ref-leaf use) @@ -300,6 +305,9 @@ (let* ((block (node-block node)) (component (block-component block))) (setf (node-reoptimize node) t) + (when (cast-p node) + (do-uses (node (cast-value node)) + (reoptimize-node node))) (reoptimize-component component t) (setf (block-reoptimize block) t))) @@ -381,7 +389,6 @@ ;;;; IR1-OPTIMIZE -#-sb-devel (declaim (start-block ir1-optimize ir1-optimize-last-effort)) ;;; Do one forward pass over COMPONENT, deleting unreachable blocks @@ -473,7 +480,11 @@ (setf (node-reoptimize node) nil) (typecase node (combination - (ir1-optimize-combination-fast node)))))) + (ir1-optimize-combination-fast node)) + (cif + ;; Don't want comparisons of constants against constants + ;; from reaching the VOPs. + (ir1-optimize-if node t)))))) ;;; Only handle constant folding, some VOPs do not work ;;; on constants. @@ -530,7 +541,9 @@ ;; type. (let ((value (exit-value node))) (when value - (derive-node-type node (lvar-derived-type value))))) + (derive-node-type node (if (lvar-single-value-p (node-lvar node)) + (lvar-type value) + (lvar-derived-type value)))))) (cset ;; PROPAGATE-FROM-SETS can do a better job if NODE-REOPTIMIZE ;; is accurate till the node actually has been reoptimized. @@ -680,7 +693,6 @@ ;;;; IF optimization -#-sb-devel (declaim (start-block ir1-optimize-if)) ;;; Check whether the predicate is known to be true or false, @@ -690,39 +702,40 @@ ;;; of them. ;;; Also, if the test has multiple uses, replicate the node when possible... ;;; in fact, splice in direct jumps to the right branch if possible. -(defun ir1-optimize-if (node) +(defun ir1-optimize-if (node &optional fast) (declare (type cif node)) - (let ((test (if-test node)) - (block (node-block node))) - (let* ((type (lvar-type test)) - (consequent (if-consequent node)) - (alternative (if-alternative node)) - (victim - (cond ((constant-lvar-p test) - (if (lvar-value test) alternative consequent)) - ((not (types-equal-or-intersect type (specifier-type 'null))) - alternative) - ((type= type (specifier-type 'null)) - consequent) - ((or (eq consequent alternative) + (let* ((test (if-test node)) + (block (node-block node))(type (lvar-type test)) + (consequent (if-consequent node)) + (alternative (if-alternative node)) + (victim + (cond ((constant-lvar-p test) + (if (lvar-value test) alternative consequent)) + ((not (types-equal-or-intersect type (specifier-type 'null))) + alternative) + ((type= type (specifier-type 'null)) + consequent) + ((eq consequent alternative) + alternative) + ((and (not fast) + (or (blocks-equivalent-p alternative consequent) - (if-test-redundant-p test consequent alternative)) - ;; Even if the references are the same they can have - ;; different derived types based on the TEST - ;; Don't lose the second type when killing it. - (let ((consequent-ref (block-start-node consequent))) - (derive-node-type consequent-ref - (values-type-union - (node-derived-type consequent-ref) - (node-derived-type (block-start-node alternative))) - :from-scratch t)) - alternative)))) - (when victim - (kill-if-branch-1 node test block victim) - (return-from ir1-optimize-if (values)))) - (tension-if-if-1 node test block) - (duplicate-if-if-1 node test block) - (values))) + (if-test-redundant-p test consequent alternative))) + ;; Even if the references are the same they can have + ;; different derived types based on the TEST + ;; Don't lose the second type when killing it. + (let ((consequent-ref (block-start-node consequent))) + (derive-node-type consequent-ref + (values-type-union + (node-derived-type consequent-ref) + (node-derived-type (block-start-node alternative))) + :from-scratch t)) + alternative)))) + (cond (victim + (kill-if-branch-1 node test block victim)) + ((not fast) + (tension-if-if-1 node test block) + (duplicate-if-if-1 node test block))))) ;; When we know that we only have a single successor, kill the victim ;; ... unless the victim and the remaining successor are the same. @@ -866,13 +879,13 @@ (node-reoptimize ref) nil) (use-lvar ref lambda-lvar) (setf (lvar-dest lambda-lvar) call) - (insert-node-before-no-split bind call) + (insert-node-before bind call) (setf (combination-kind call) :local (combination-args call) args) (loop for arg in args when arg do (setf (lvar-dest arg) call)) - (insert-node-before-no-split call ref)) + (insert-node-before call ref)) t)))))) ;; Finally, duplicate EQ-nil tests @@ -962,22 +975,32 @@ (when (and entry (eq (node-home-lambda node) (node-home-lambda entry))) (setf (entry-exits entry) (delq1 node (entry-exits entry))) - (if value - (delete-filter node (node-lvar node) value) - (unlink-node node))))) + (cond (value + ;; The number of consumed values is now known, reoptimize the users. + ;; The VALUES transform in particular benefits from this. + (do-uses (use value) + (reoptimize-node use)) + (delete-filter node (node-lvar node) value)) + (t + (unlink-node node)))))) ;;;; combination IR1 optimization -#-sb-devel (declaim (start-block ir1-optimize-combination maybe-terminate-block - system-inline-fun-p validate-call-type)) (defun check-important-result (node info) (when (and (null (node-lvar node)) (ir1-attributep (fun-info-attributes info) important-result) (neq (combination-info node) :important-result-discarded)) + (when (lvar-fun-is (combination-fun node) '(adjust-array)) + (let ((type (lvar-type (car (combination-args node))))) + ;; - if the array is simple, then result is important + ;; - if non-simple, then result is not important + ;; - if not enough information, then don't warn + (when (or (not (array-type-p type)) (array-type-complexp type)) ; T or :MAYBE + (return-from check-important-result)))) (let ((*compiler-error-context* node)) (setf (combination-info node) :important-result-discarded) (compiler-style-warn @@ -1052,7 +1075,7 @@ (make-gensym-list (length (combination-args node)))) (setq passed-args (copy-list received-args))) (let ((tempname (let ((*gensym-counter* (length dx-flets))) - (gensym "LAMBDA"))) + (sb-xc:gensym "LAMBDA"))) (original-lambda (functional-inline-expansion (lambda-entry-fun (ref-leaf use))))) @@ -1082,12 +1105,12 @@ ;;; the code - it does; but compiler doesn't appear to respect the DX-FLET. (defglobal *dxify-args-transform* (make-transform :type (specifier-type 'function) - :function (lambda (node) + :%fun (lambda (node) + "auto-DX" (or (let ((name (combination-fun-source-name node))) (dxify-downward-funargs node (fun-name-dx-args name) name)) - (give-up-ir1-transform))) - :note "auto-DX")) + (give-up-ir1-transform))))) (defun check-proper-sequences (combination info) (when (fun-info-annotation info) @@ -1104,8 +1127,8 @@ combination info))) ;;; Do IR1 optimizations on a COMBINATION node. -(declaim (ftype (function (combination) (values)) ir1-optimize-combination)) -(defun ir1-optimize-combination (node) +(defun ir1-optimize-combination (node &aux (show *show-transforms-p*)) + (declare (type combination node)) (when (lvar-reoptimize (basic-combination-fun node)) (propagate-fun-change node) (when (node-deleted node) @@ -1125,6 +1148,8 @@ (when fun (let ((res (funcall fun node))) (when res + (when (eq show :derive-type) + (show-type-derivation node res)) (derive-node-type node (coerce-to-values res)) (maybe-terminate-block node nil))))))) (ecase kind @@ -1174,6 +1199,8 @@ (when (constant-fold-call-p node) (constant-fold-call node) (return-from ir1-optimize-combination)) + (when (fold-call-derived-to-constant node) + (return-from ir1-optimize-combination)) (when (and (ir1-attributep attr commutative) (= (length args) 2) (constant-lvar-p (first args)) @@ -1203,14 +1230,14 @@ ;; Are type checks getting in the way? (or (try-equality-constraint node) (dolist (x (fun-info-transforms info)) - (when (eq *show-transforms-p* :all) + (when (eq show :all) (let* ((lvar (basic-combination-fun node)) (fname (lvar-fun-name lvar t))) (format *trace-output* "~&trying transform ~s for ~s" (transform-type x) fname))) - (unless (ir1-transform node x) - (when (eq *show-transforms-p* :all) + (unless (ir1-transform node x show) + (when (eq show :all) (format *trace-output* "~&quitting because IR1-TRANSFORM result was NIL")) (return)))))))))))))) @@ -1248,11 +1275,18 @@ (succ (first (block-succ block)))) (declare (ignore lvar)) (unless (or (and (eq node (block-last block)) (eq succ tail)) - (block-delete-p block)) - ;; Even if the combination will never return, don't terminate if this - ;; is the tail call of a XEP: doing that would inhibit TCO. - (when (and (eq (node-derived-type node) *empty-type*) - (not (xep-tail-combination-p node))) + (block-delete-p block) + ;; Even if the combination will never return, don't + ;; terminate if this is the tail call of a XEP: doing + ;; that would inhibit TCO. + (xep-tail-combination-p node) + ;; Do not consider the block for termination if this + ;; is a LET-like combination, since the successor of + ;; this node is the body of the LET. + (and (combination-p node) + (eq (combination-kind node) :local) + (functional-somewhat-letlike-p (combination-lambda node)))) + (when (eq (node-derived-type node) *empty-type*) (cond (ir1-converting-not-optimizing-p (cond ((block-last block) @@ -1279,13 +1313,6 @@ (mark-for-deletion succ))))) t)))) -(defun system-inline-fun-p (name) - (and (symbolp name) - (let ((package (cl:symbol-package name))) - (and package - (or (eq package *cl-package*) - (system-package-p package)))))) - ;;; This is called both by IR1 conversion and IR1 optimization when ;;; they have verified the type signature for the call, and are ;;; wondering if something should be done to special-case the call. If @@ -1312,6 +1339,8 @@ (defined-fun-inlinep leaf) 'no-chance))) (cond + ((eq (basic-combination-kind call) :error) + (values nil nil)) (unknown-keys (setf (basic-combination-kind call) :unknown-keys) (values leaf nil)) @@ -1343,17 +1372,19 @@ ;; It has already been processed by locall, ;; inline again. (functional-kind fun)) + (when (eq (car *current-path*) 'original-source-start) + (setf (ctran-source-path (node-prev call)) *current-path*)) ;; Convert. (let* ((name (leaf-source-name leaf)) (*inline-expansions* (register-inline-expansion leaf call)) - (*transforming* (system-inline-fun-p name)) (res (ir1-convert-inline-expansion name (defined-fun-inline-expansion leaf) leaf inlinep (info :function :info name)))) + ;; Allow backward references to this function from following ;; forms. (Reused only if policy matches.) (push res (defined-fun-functionals leaf)) @@ -1419,8 +1450,11 @@ (cond (valid (assert-call-type call type) (maybe-terminate-block call ir1-converting-not-optimizing-p) - (setf (combination-kind call) :full) - (recognize-known-call call ir1-converting-not-optimizing-p unknown-keys)) + (cond ((eq (combination-kind call) :error) + (values nil nil)) + (t + (setf (combination-kind call) :full) + (recognize-known-call call ir1-converting-not-optimizing-p unknown-keys)))) (t (setf (combination-kind call) :error) (values nil nil)))))))) @@ -1440,7 +1474,8 @@ (case (combination-kind call) (:local (let ((fun (combination-lambda call))) - (maybe-let-convert fun) + (or (maybe-let-convert fun) + (maybe-convert-to-assignment fun)) (unless (member (functional-kind fun) '(:let :assignment :deleted)) (derive-node-type call (tail-set-type (lambda-tail-set fun)))))) (:full @@ -1497,11 +1532,11 @@ ;;; finalize to pick up. We return true if the transform failed, and ;;; thus further transformation should be attempted. We return false ;;; if either the transform succeeded or was aborted. -(defun ir1-transform (node transform) +(defun ir1-transform (node transform show) (declare (type combination node) (type transform transform)) (declare (notinline warn)) ; See COMPILER-WARN for rationale (let* ((type (transform-type transform)) - (fun (transform-function transform)) + (fun (transform-%fun transform)) (constrained (fun-type-p type)) (table (component-failed-optimizations *component-being-compiled*)) (flame (case (transform-important transform) @@ -1515,14 +1550,13 @@ (valid-fun-use node type)) (multiple-value-bind (severity args) (catch 'give-up-ir1-transform - (transform-call node - (let ((new-form (funcall fun node))) - (when *show-transforms-p* - (show-transform "ir" - (combination-fun-source-name node) - new-form)) - new-form) - (combination-fun-source-name node)) + (let ((new-form (if (listp fun) ; the deftransform had :INFO + (funcall (car fun) node (cdr fun)) + (funcall fun node))) + (fun-name (combination-fun-source-name node))) + (when (show-transform-p show fun-name) + (show-transform "ir" fun-name new-form node)) + (transform-call node new-form fun-name)) (values :none nil)) (ecase severity (:none @@ -1586,6 +1620,9 @@ (throw 'give-up-ir1-transform (values :failure args))) (defun abort-ir1-transform (&rest args) (throw 'give-up-ir1-transform (values :aborted args))) + +(defvar *delayed-ir1-transforms*) + (defun delay-ir1-transform (node &rest reasons) (let ((assoc (assoc node *delayed-ir1-transforms*))) (cond ((not assoc) @@ -1668,7 +1705,10 @@ (with-ir1-environment-from-node call (with-component-last-block (*current-component* (block-next (node-block call))) - (let* ((*transforming* t) + (unless (or (memq 'transformed *current-path*) + (memq 'inlined *current-path*)) + (setf (ctran-source-path (node-prev call)) *current-path*)) + (let* ((*transforming* (1+ *transforming*)) (new-fun (ir1-convert-inline-lambda res :debug-name (debug-name 'lambda-inlined source-name) @@ -1779,10 +1819,18 @@ values))) fun-name))))))) (values)) + +(defun fold-call-derived-to-constant (call) + (when (flushable-combination-p call) + (let ((type (node-derived-type call))) + (when (type-single-value-p type) + (multiple-value-bind (single-p value) (type-singleton-p (single-value-type type)) + (when single-p + (replace-combination-with-constant value call) + t)))))) ;;;; local call optimization -#-sb-devel (declaim (start-block ir1-optimize-set constant-reference-p delete-let propagate-let-args propagate-local-call-args propagate-to-refs propagate-from-sets @@ -1850,85 +1898,123 @@ high (max this-high (or high this-high)))))) type)) -;;; Iteration variable: exactly one SETQ of the form: +;;; Iteration variable: only SETQs of the form: ;;; ;;; (let ((var initial)) ;;; ... -;;; (setq var (+ var step)) +;;; (setq var (+/- var step_1)) +;;; ... +;;; (setq var (+/- var step_k)) ;;; ...) +;;; +;;; such that the modifications either all increment or all decrement +;;; VAR. +(declaim (inline %inc-or-dec-p)) +(defun %inc-or-dec-p (node) + (and (combination-p node) + (eq (combination-kind node) :known) + (fun-info-p (combination-fun-info node)) + (not (node-to-be-deleted-p node)) + (let ((source-name (combination-fun-source-name node))) + (when (memq source-name '(- +)) + source-name)))) + +(defun %analyze-set-uses (sets var initial-type) + (let ((some-plusp nil) + (some-minusp nil) + (set-types '()) + (every-set-type-suitable-p t)) + (dolist (set sets) + (let* ((set-use (principal-lvar-use (set-value set))) + (function (%inc-or-dec-p set-use))) + (unless function ; every use must be + or - + (return-from %analyze-set-uses nil)) + (let ((args (basic-combination-args set-use))) + ;; Every use must be of the form ({+,-} VAR STEP). + (unless (and (proper-list-of-length-p args 2 2) + (let ((first (principal-lvar-use (first args)))) + (and (ref-p first) + (eq (ref-leaf first) var)))) + (return-from %analyze-set-uses nil)) + (let ((step-type (lvar-type (second args))) + (set-type (lvar-type (set-value set)))) + ;; In ({+,-} VAR STEP), the type of STEP must be a numeric + ;; type matching INITIAL-TYPE. + (unless (and (numeric-type-p step-type) + (or (numeric-type-equal initial-type step-type) + ;; Detect cases like (LOOP FOR 1.0 to 5.0 + ;; ...), where the initial and the step + ;; are of different types, and the step + ;; is less contagious. + (let ((contagion-type (numeric-contagion initial-type + step-type))) + (and (numeric-type-p contagion-type) + (numeric-type-equal initial-type contagion-type))))) + (return-from %analyze-set-uses nil)) + ;; Track the directions of the increments/decrements. + (let ((non-negative-p (csubtypep step-type (specifier-type '(real 0 *)))) + (non-positive-p (csubtypep step-type (specifier-type '(real * 0))))) + (cond ((or (and (eq function '+) non-negative-p) + (and (eq function '-) non-positive-p)) + (setf some-plusp t)) + ((or (and (eq function '-) non-negative-p) + (and (eq function '+) non-positive-p)) + (setf some-minusp t)) + (t ; Can't tell direction + (setf some-plusp t some-minusp t)))) + ;; Ultimately, the derived types of the sets must match + ;; INITIAL-TYPE if we are going to derive new bounds. + (unless (and (numeric-type-p set-type) + (numeric-type-equal set-type initial-type)) + (setf every-set-type-suitable-p nil)) + (push set-type set-types))))) + (values (cond ((and some-plusp (not some-minusp)) '+) + ((and some-minusp (not some-plusp)) '-) + (t '*)) + set-types every-set-type-suitable-p))) + (defun maybe-infer-iteration-var-type (var initial-type) (binding* ((sets (lambda-var-sets var) :exit-if-null) - (set (first sets)) - (() (null (rest sets)) :exit-if-null) - (set-use (principal-lvar-use (set-value set))) - (() (and (combination-p set-use) - (eq (combination-kind set-use) :known) - (fun-info-p (combination-fun-info set-use)) - (not (node-to-be-deleted-p set-use)) - (or (eq (combination-fun-source-name set-use) '+) - (eq (combination-fun-source-name set-use) '-))) - :exit-if-null) - (minusp (eq (combination-fun-source-name set-use) '-)) - (+-args (basic-combination-args set-use)) - (() (and (proper-list-of-length-p +-args 2 2) - (let ((first (principal-lvar-use - (first +-args)))) - (and (ref-p first) - (eq (ref-leaf first) var)))) - :exit-if-null) - (step-type (lvar-type (second +-args))) - (set-type (lvar-type (set-value set))) - (initial-type (weaken-numeric-union-type initial-type))) - (when (and (numeric-type-p initial-type) - (numeric-type-p step-type) - (or (numeric-type-equal initial-type step-type) - ;; Detect cases like (LOOP FOR 1.0 to 5.0 ...), where - ;; the initial and the step are of different types, - ;; and the step is less contagious. - (numeric-type-equal initial-type - (numeric-contagion initial-type - step-type)))) - (labels ((leftmost (x y cmp cmp=) - (cond ((eq x nil) nil) - ((eq y nil) nil) - ((listp x) - (let ((x1 (first x))) - (cond ((listp y) - (let ((y1 (first y))) - (if (funcall cmp x1 y1) x y))) - (t - (if (funcall cmp x1 y) x y))))) - ((listp y) - (let ((y1 (first y))) - (if (funcall cmp= x y1) x y))) - (t (if (funcall cmp x y) x y)))) - (max* (x y) (leftmost x y #'> #'>=)) - (min* (x y) (leftmost x y #'< #'<=))) - (multiple-value-bind (low high) - (let ((step-type-non-negative (csubtypep step-type (specifier-type - '(real 0 *)))) - (step-type-non-positive (csubtypep step-type (specifier-type - '(real * 0))))) - (cond ((or (and step-type-non-negative (not minusp)) - (and step-type-non-positive minusp)) - (values (numeric-type-low initial-type) - (when (and (numeric-type-p set-type) - (numeric-type-equal set-type initial-type)) - (max* (numeric-type-high initial-type) - (numeric-type-high set-type))))) - ((or (and step-type-non-positive (not minusp)) - (and step-type-non-negative minusp)) - (values (when (and (numeric-type-p set-type) - (numeric-type-equal set-type initial-type)) - (min* (numeric-type-low initial-type) - (numeric-type-low set-type))) - (numeric-type-high initial-type))) - (t - (values nil nil)))) - (modified-numeric-type initial-type - :low low - :high high - :enumerable nil)))))) + (initial-type (weaken-numeric-union-type initial-type)) + ((direction set-types every-set-type-suitable-p) + (when (numeric-type-p initial-type) + (%analyze-set-uses sets var initial-type)) + :exit-if-null)) + (labels ((leftmost (x y cmp cmp=) + (cond ((eq x nil) nil) + ((eq y nil) nil) + ((listp x) + (let ((x1 (first x))) + (cond ((listp y) + (let ((y1 (first y))) + (if (funcall cmp x1 y1) x y))) + (t + (if (funcall cmp x1 y) x y))))) + ((listp y) + (let ((y1 (first y))) + (if (funcall cmp= x y1) x y))) + (t (if (funcall cmp x y) x y))))) + (multiple-value-bind (low high) + (ecase direction + (+ + (values (numeric-type-low initial-type) + (when every-set-type-suitable-p + (reduce (lambda (x y) (leftmost x y #'> #'>=)) set-types + :initial-value (numeric-type-high initial-type) + :key #'numeric-type-high))) + ) + (- + (values (when every-set-type-suitable-p + (reduce (lambda (x y) (leftmost x y #'< #'<=)) set-types + :initial-value (numeric-type-low initial-type) + :key #'numeric-type-low)) + (numeric-type-high initial-type))) + (* + (values nil nil))) + (modified-numeric-type initial-type :low low + :high high + :enumerable nil))))) + (deftransform + ((x y) * * :result result) "check for iteration variable reoptimization" (let ((dest (principal-lvar-end result)) @@ -1942,7 +2028,7 @@ ;;; Figure out the type of a LET variable that has sets. We compute ;;; the union of the INITIAL-TYPE and the types of all the set -;;; values and to a PROPAGATE-TO-REFS with this type. +;;; values and do a PROPAGATE-TO-REFS with this type. (defun propagate-from-sets (var initial-type) (let ((types nil)) (dolist (set (lambda-var-sets var)) @@ -2068,7 +2154,11 @@ (eq (node-home-lambda ref) (lambda-home (lambda-var-home var)))) (let ((ref-type (single-value-type (node-derived-type ref)))) - (cond ((csubtypep (single-value-type (lvar-type arg)) ref-type) + (cond ((or (csubtypep (single-value-type (lvar-type arg)) ref-type) + ;; Can't impart the same type to multiple uses, as + ;; they are coming from different branches with + ;; different derived values. + (consp (lvar-uses lvar))) (substitute-lvar-uses lvar arg ;; Really it is (EQ (LVAR-USES LVAR) REF): t) @@ -2076,9 +2166,8 @@ (t (let* ((value (make-lvar)) (cast (insert-cast-before ref value ref-type - ;; KLUDGE: it should be (TYPE-CHECK 0) - *policy*))) - (setf (cast-type-to-check cast) *wild-type*) + **zero-typecheck-policy**))) + (setf (cast-%type-check cast) nil) (substitute-lvar-uses value arg ;; FIXME t) @@ -2102,10 +2191,14 @@ (declare (type clambda clambda)) (aver (functional-letlike-p clambda)) (note-unreferenced-fun-vars clambda) - (let ((call (let-combination clambda))) + (let ((call (let-combination clambda)) + (bind (lambda-bind clambda))) (flush-dest (basic-combination-fun call)) + (when (eq (car (node-source-path bind)) 'original-source-start) + (setf (ctran-source-path (node-prev (car (leaf-refs clambda)))) + (node-source-path bind))) (unlink-node call) - (unlink-node (lambda-bind clambda)) + (unlink-node bind) (setf (lambda-bind clambda) nil)) (setf (functional-kind clambda) :zombie) (let ((home (lambda-home clambda))) @@ -2259,7 +2352,8 @@ (let ((lambda (combination-lambda node))) (when (lvar-reoptimize fun) (setf (lvar-reoptimize fun) nil) - (maybe-let-convert lambda)) + (or (maybe-let-convert lambda) + (maybe-convert-to-assignment lambda))) (cond ((neq (functional-kind lambda) :mv-let) (loop for arg in (basic-combination-args node) do @@ -2282,7 +2376,8 @@ (when (and (ref-p use) (functional-p (ref-leaf use))) (convert-call-if-possible use node) (when (eq (basic-combination-kind node) :local) - (maybe-let-convert (ref-leaf use)))))) + (or (maybe-let-convert (ref-leaf use)) + (maybe-convert-to-assignment (ref-leaf use))))))) (unless (or (eq (basic-combination-kind node) :local) (eq (lvar-fun-name fun) '%throw)) (ir1-optimize-mv-call node)))) @@ -2496,14 +2591,14 @@ (let ((arg (pop args)) (new-lvar (pop lvars)) (type (pop types))) - (if (and type - (not (type-asserted-p arg type))) - ;; Propagate derived types from the VALUES call to its args: - ;; transforms can leave the VALUES call with a better type - ;; than its args have, so make sure not to throw that away. - (use-lvar (insert-cast-before use arg type **zero-typecheck-policy**) - new-lvar) - (substitute-lvar-uses new-lvar arg nil)))) + (when (and type + (not (type-asserted-p arg type))) + ;; Propagate derived types from the VALUES call to its args: + ;; transforms can leave the VALUES call with a better type + ;; than its args have, so make sure not to throw that away. + (do-uses (node arg) + (derive-node-type node type))) + (substitute-lvar-uses new-lvar arg nil))) ;; Discard unused arguments (loop for arg in args do (flush-dest arg)) @@ -2543,14 +2638,18 @@ (when (combination-p use) (let ((name (lvar-fun-name (combination-fun use))) (args (combination-args use))) + ;; Recognizing LIST* seems completely ad-hoc, however, once upon a time + ;; (LIST x) was translated to (CONS x NIL), so in order for this optimizer to + ;; pick off (VALUES-LIST (LIST x)), it had to instead look for (CONS x NIL). + ;; Realistically nobody should hand-write (VALUES-LIST ({CONS | LIST*} x NIL)) + ;; so it seems very questionable in utility to preserve both spellings. (when (or (eq name 'list) - (and (eq name 'cons) - (let ((cdr (second args))) - (and (constant-lvar-p cdr) - (null (lvar-value cdr)) + (and (eq name 'list*) + (let ((cdr (car (last args)))) + (and (lvar-value-is-nil cdr) (progn (flush-dest cdr) - (setf (cdr args) nil) + (setf args (butlast args)) t))))) ;; FIXME: VALUES might not satisfy an assertion on NODE-LVAR. @@ -2593,6 +2692,13 @@ (not (node-deleted (bound-cast-check cast)))) (flush-combination (bound-cast-check cast)) (setf (bound-cast-check cast) nil)) + (unless (array-index-cast-p cast) + ;; Normally the types are the same, as the cast gets its derived + ;; type from the lvar, but it may get a different type when an + ;; inlined function with a derived type is let-converted. + (let ((type (node-derived-type cast))) + (do-uses (node value) + (derive-node-type node type)))) (delete-filter cast lvar value) (when lvar (reoptimize-lvar lvar) @@ -2617,12 +2723,23 @@ (defun may-delete-cast (cast) (typecase cast - (vestigial-exit-cast - nil) + (delay nil) (bound-cast (may-delete-bound-cast cast)) (t t))) +(defun cast-mismatch-from-inlined-p (cast node) + (let* ((path (node-source-path node)) + (transformed (memq 'transformed path)) + (inlined)) + (cond ((and transformed + (not (eq (memq 'transformed (node-source-path cast)) + transformed)))) + ((setf inlined + (memq 'inlined path)) + (not (eq (memq 'inlined (node-source-path cast)) + inlined)))))) + ;;; Delete or move around casts when possible (defun maybe-delete-cast (cast) (let ((lvar (cast-lvar cast)) @@ -2657,7 +2774,10 @@ (link-blocks (node-block use) next-block) ;; At least one use is good, downgrade any possible ;; type conflicts to style warnings. - (setf (cast-silent-conflict cast) :style-warning) + (setf (cast-silent-conflict cast) + (if (cast-mismatch-from-inlined-p cast use) + t + :style-warning)) (when (and (return-p dest) (basic-combination-p use) (eq (basic-combination-kind use) :local)) @@ -2698,43 +2818,43 @@ (context (if (local-call-context-p context) (local-call-context-var context) context))) - (unless (cast-silent-conflict cast) + (when (or (not (cast-silent-conflict cast)) + (and (eq (cast-silent-conflict cast) :style-warning) + (not (cast-single-value-p cast)) + (setf context :multiple-values))) (filter-lvar value (if (cast-single-value-p cast) - `(list 'dummy) - `(multiple-value-call #'list 'dummy)))) + (lambda (dummy) `(list ,dummy)) + (lambda (dummy) `(multiple-value-call #'list ,dummy))))) (filter-lvar (cast-value cast) ;; FIXME: Derived type. (if (cast-silent-conflict cast) - (let ((dummy-sym (gensym))) - `(let ((,dummy-sym 'dummy)) - ,@(and (eq (cast-silent-conflict cast) :style-warning) - `((%compile-time-type-style-warn ,dummy-sym - ',(type-specifier atype) - ',(type-specifier value-type) - ',detail - ',(compile-time-type-error-context source-form) - ',context))) - ,(internal-type-error-call dummy-sym atype context) - ,dummy-sym)) - `(%compile-time-type-error 'dummy - ',(type-specifier atype) - ',(type-specifier value-type) - ',detail - ',(compile-time-type-error-context source-form) - ',context)))) - ;; KLUDGE: FILTER-LVAR does not work for non-returning - ;; functions, so we declare the return type of - ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type - ;; here. - (setq value (cast-value cast)) - (derive-node-type (lvar-uses value) *empty-type*) - (maybe-terminate-block (lvar-uses value) nil) - ;; FIXME: Is it necessary? - (aver (null (block-pred (node-block cast)))) - (delete-block-lazily (node-block cast)) + (lambda (dummy) + (let ((dummy-sym (gensym))) + `(let ((,dummy-sym ,dummy)) + ,@(and (eq (cast-silent-conflict cast) :style-warning) + `((%compile-time-type-style-warn ,dummy-sym + ',(type-specifier atype) + ',(type-specifier value-type) + ',detail + ',(compile-time-type-error-context source-form) + ',context))) + ,(internal-type-error-call dummy-sym atype context) + ,dummy-sym))) + (lambda (dummy) + `(%compile-time-type-error ,dummy + ',(type-specifier atype) + ',(type-specifier value-type) + ',detail + ',(compile-time-type-error-context source-form) + ',context)))) + ;; maybe-terminate-block during ir1-convert (in filter-lvar) doesn't + ;; properly terminate blocks for NIL returning functions, do it manually here. + (setq value (cast-value cast)) + (derive-node-type (lvar-uses value) *empty-type*) + (maybe-terminate-block (lvar-uses value) nil)) (return-from ir1-optimize-cast))) (when (eq (node-derived-type cast) *empty-type*) (maybe-terminate-block cast nil)) diff -Nru sbcl-2.1.1/src/compiler/ir1report.lisp sbcl-2.1.11/src/compiler/ir1report.lisp --- sbcl-2.1.1/src/compiler/ir1report.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1report.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -80,30 +80,39 @@ (args (compiler-error-context-format-args context))) (collect ((full nil cons) (short nil cons)) - (let* ((forms (source-path-forms path)) - (n 0) - (forms (if (member (first forms) args) - (rest forms) - forms)) - (transforms (memq 'transformed forms)) - (forms (if transforms - (cdr transforms) - forms))) - (dolist (src forms) - (if (>= n *enclosing-source-cutoff*) - (short (stringify-form (if (consp src) - (car src) - src) - nil)) - (full (stringify-form src))) - (incf n)) - (setf (compiler-error-context-%enclosing-source context) (short) - (compiler-error-context-%source context) (full))))))) + (flet ((no-transforms (x) + (let ((pos (position 'transformed x :from-end t))) + (if pos + (subseq x (1+ pos)) + x))) + (hide-inlines (x) + (loop for elt = (pop x) + while x + if (eq elt 'inlined) + do (pop x) + else + collect elt))) + (let* ((forms (source-path-forms path)) + (n 0) + (forms (if (member (first forms) args) + (rest forms) + forms)) + (forms (hide-inlines (no-transforms forms)))) + (dolist (src forms) + (if (>= n *enclosing-source-cutoff*) + (short (stringify-form (if (consp src) + (car src) + src) + nil)) + (full (stringify-form src))) + (incf n)) + (setf (compiler-error-context-%enclosing-source context) (short) + (compiler-error-context-%source context) (full)))))))) ;;; If true, this is the node which is used as context in compiler warning ;;; messages. (declaim (type (or null compiler-error-context node - lvar-annotation) *compiler-error-context*)) + lvar-annotation ctran) *compiler-error-context*)) (defvar *compiler-error-context* nil) ;;; a plist mapping macro names to source context parsers. Each parser @@ -239,7 +248,7 @@ ;;; If OLD-CONTEXTS is passed in, and includes a context with the ;;; same original source path as the new context would have, the old ;;; context is reused instead, and a secondary value of T is returned. -(defun find-error-context (args &optional old-contexts) +(defun find-error-context (args &optional old-contexts (old-contexts-key #'identity)) (let ((context *compiler-error-context*)) (if (compiler-error-context-p context) (values context t) @@ -247,13 +256,18 @@ (node-source-path context)) ((lvar-annotation-p context) (lvar-annotation-source-path context)) + ((ctran-p context) + (ctran-source-path context)) ((boundp '*current-path*) *current-path*))) (old (find (when path (source-path-original-source path)) - (remove-if #'null old-contexts) + old-contexts :test #'equal - :key #'compiler-error-context-original-source-path))) + :key (lambda (x) + (and x + (compiler-error-context-original-source-path + (funcall old-contexts-key x))))))) (if old (values old t) (when (and *source-info* path) @@ -265,7 +279,10 @@ :original-form form :format-args args :context src-context - :file-name (file-info-name file-info) + :file-name (if (symbolp (file-info-truename file-info)) ; :LISP or :STREAM + ;; (pathname will be NIL in those two cases) + (file-info-truename file-info) + (file-info-pathname file-info)) :file-position (nth-value 1 (find-source-root tlf *source-info*)) :path path @@ -434,6 +451,7 @@ (:documentation "A condition type signalled when the compiler deletes code that the user has written, having proved that it is unreachable.")) +(define-condition unknown-typep-note (simple-compiler-note) ()) (define-condition compiler-macro-application-missed-warning (style-warning) @@ -474,8 +492,11 @@ (defun compiler-notify (datum &rest args) (unless (if *compiler-error-context* - (policy *compiler-error-context* (= inhibit-warnings 3)) - (policy *lexenv* (= inhibit-warnings 3))) + (policy (if (ctran-p *compiler-error-context*) + (ctran-next *compiler-error-context*) + *compiler-error-context*) + (= inhibit-warnings 3)) + (policy *lexenv* (= inhibit-warnings 3))) (with-condition (condition datum args) (incf *compiler-note-count*) (print-compiler-message @@ -536,6 +557,8 @@ (defvar *compiler-style-warning-count*) (defvar *compiler-note-count*) +(defvar *methods-in-compilation-unit*) + ;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call ;;; should return WARNINGS-P or FAILURE-P. (defvar *failure-p*) @@ -627,6 +650,41 @@ (incf (undefined-warning-count res)))))) (values)) +(defun note-key-arg-mismatch (name keys) + (let* ((found (find name + *argument-mismatch-warnings* + :key #'argument-mismatch-warning-name)) + (res (or found + (make-argument-mismatch-warning :name name)))) + (unless found + (push res *argument-mismatch-warnings*)) + (multiple-value-bind (context old) + (find-error-context (list name) (argument-mismatch-warning-warnings res) #'cdr) + (unless old + (push (cons keys context) (argument-mismatch-warning-warnings res)))))) + +(defun report-key-arg-mismatches () + #-sb-xc-host + (loop for warning in *argument-mismatch-warnings* + for name = (argument-mismatch-warning-name warning) + for type = (sb-pcl::compute-gf-ftype name) + when (and (fun-type-p type) + (not (fun-type-allowp type))) + do + (loop for (keys . context) in (argument-mismatch-warning-warnings warning) + for bad = (loop for key in keys + when (not (member key (fun-type-keywords type) + :key #'key-info-name)) + collect key) + do (let ((*compiler-error-context* context)) + (cond ((cdr bad) + (compiler-style-warn "~@<~{~S~^, ~} and ~S are not a known argument keywords.~:@>" + (butlast bad) + (car (last bad)))) + (bad + (compiler-style-warn "~S is not a known argument keyword." + (car bad)))))))) + ;; The compiler tracks full calls that were emitted so that it is possible ;; to detect a definition of a compiler-macro occuring after the first ;; compile-time observed use of (vs. actual call of) that function name. @@ -665,7 +723,7 @@ ;; (defun warn-if-inline-failed/proclaim (name new-inlinep) (when (eq new-inlinep 'inline) - (let ((warning-count (emitted-full-call-count name))) + (let ((warning-count (sb-impl::emitted-full-call-count name))) (when (and warning-count ;; Warn only if the the compiler did not have the expansion. (not (fun-name-inline-expansion name)) diff -Nru sbcl-2.1.1/src/compiler/ir1tran-lambda.lisp sbcl-2.1.11/src/compiler/ir1tran-lambda.lisp --- sbcl-2.1.1/src/compiler/ir1tran-lambda.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1tran-lambda.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -20,7 +20,6 @@ ;;;; Note: Take a look at the compiler-overview.tex section on "Hairy ;;;; function representation" before you seriously mess with this ;;;; stuff. -#-sb-devel (declaim (start-block ir1-convert-lambda ir1-convert-lambda-body ir1-convert-aux-bindings varify-lambda-arg ir1-convert-lambdalike)) @@ -201,7 +200,8 @@ debug-name (note-lexical-bindings t) post-binding-lexenv - system-lambda) + system-lambda + local-policy) (declare (list body vars aux-vars aux-vals)) ;; We're about to try to put new blocks into *CURRENT-COMPONENT*. @@ -209,10 +209,13 @@ (let* ((bind (make-bind)) (lambda (make-lambda :vars vars - :bind bind - :%source-name source-name - :%debug-name debug-name - :system-lambda-p system-lambda)) + :bind bind + :%source-name source-name + :%debug-name debug-name + :system-lambda-p system-lambda + :lexenv (if local-policy + (make-lexenv :policy local-policy) + *lexenv*))) (result-ctran (make-ctran)) (result-lvar (make-lvar))) ;; just to check: This function should fail internal assertions if @@ -480,7 +483,9 @@ (found-allow-p nil)) (temps #-stack-grows-downward-not-upward - `(,n-index (1- ,n-count)) + `(,n-index (+ ,n-count ,(if (vop-existsp :translate %more-keyword-pair) + 0 + -1))) #+stack-grows-downward-not-upward `(,n-index (- (1- ,n-count))) #-stack-grows-downward-not-upward n-value-temp @@ -536,7 +541,9 @@ (setq ,n-lose ,n-key)))) (body - `(when (oddp ,n-count) + `(when (oddp ,(if (vop-existsp :translate %more-keyword-pair) + n-index + n-count)) (%odd-key-args-error))) (body @@ -544,12 +551,19 @@ `(locally (declare (optimize (safety 0))) (loop - (when (minusp ,n-index) (return)) - (setf ,n-value-temp (%more-arg ,n-context ,n-index)) - (decf ,n-index) - (setq ,n-key (%more-arg ,n-context ,n-index)) - (decf ,n-index) - (case ,n-key ,@(tests)))) + ,@(cond ((vop-existsp :translate %more-keyword-pair) + `((when (zerop ,n-index) (return)) + (decf ,n-index 2) + (multiple-value-bind (key value) + (%more-keyword-pair ,n-context ,n-index) + (setf ,n-value-temp value ,n-key key)))) + (t + `((when (minusp ,n-index) (return)) + (setf ,n-value-temp (%more-arg ,n-context ,n-index)) + (decf ,n-index) + (setq ,n-key (%more-arg ,n-context ,n-index)) + (decf ,n-index)))) + (case ,n-key ,@(tests)))) #+stack-grows-downward-not-upward `(locally (declare (optimize (safety 0))) (loop @@ -884,7 +898,8 @@ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals) (make-lambda-vars (cadr form)) (binding* (((*lexenv* result-type post-binding-lexenv - lambda-list explicit-check source-form) + lambda-list explicit-check source-form + local-policy) (process-decls decls (append aux-vars vars) nil :binding-form-p t :allow-lambda-list t)) (debug-catch-p (and maybe-add-debug-catch @@ -913,7 +928,8 @@ :post-binding-lexenv post-binding-lexenv :source-name source-name :debug-name debug-name - :system-lambda system-lambda))))) + :system-lambda system-lambda + :local-policy local-policy))))) (when explicit-check (setf (getf (functional-plist res) 'explicit-check) explicit-check)) (setf (functional-inline-expansion res) (or source-form form)) @@ -1055,7 +1071,120 @@ (allow (when (ll-kwds-allowp llks) '(&allow-other-keys)))) (careful-specifier-type `(function (,@reqs ,@opts ,@rest ,@keys ,@allow) *)))))) -#-sb-devel +(declaim (start-block maybe-inline-syntactic-closure)) + +;;; Take the lexenv surrounding an inlined function and extract things +;;; needed for the inline expansion suitable for dumping into fasls. +;;; Right now it's MACROLET, SYMBOL-MACROLET, SPECIAL and +;;; INLINE/NOTINLINE declarations. Upon encountering something else return NIL. +;;; This is later used by PROCESS-INLINE-LEXENV to reproduce the lexenv. +;;; +;;; Previously it just used the functions and vars of the innermost +;;; lexenv, but the body of macrolet can refer to other macrolets +;;; defined earlier, so it needs to process all the parent lexenvs to +;;; recover the proper order. +(defun reconstruct-lexenv (lexenv) + (let (shadowed-funs + shadowed-vars + result) + (loop for env = lexenv then parent + for parent = (lexenv-parent env) + for vars = (lexenv-vars env) + for funs = (lexenv-funs env) + for declarations = nil + for symbol-macros = nil + for macros = nil + do + (loop for binding in vars + for (name . what) = binding + unless (and parent + (find binding (lexenv-vars parent))) + do (typecase what + (cons + (aver (eq (car what) 'macro)) + (push name shadowed-vars) + (push (list name (cdr what)) symbol-macros)) + (global-var + (aver (eq (global-var-kind what) :special)) + (push `(special ,name) declarations)) + (t + (unless (memq name shadowed-vars) + (return-from reconstruct-lexenv))))) + (loop for binding in funs + for (name . what) = binding + unless (and parent + (find binding (lexenv-funs parent))) + do + (typecase what + (cons + (push name shadowed-funs) + (let ((expression (function-lambda-expression (cdr what)))) + (aver expression) + (push (cons name expression) macros))) + ;; FIXME: Is there a good reason for this not to be + ;; DEFINED-FUN (which :INCLUDEs GLOBAL-VAR, in case + ;; you're wondering how this ever worked :-)? Maybe + ;; in conjunction with an AVERrance that it's not an + ;; (AND GLOBAL-VAR (NOT GLOBAL-FUN))? -- CSR, + ;; 2002-07-08 + (global-var + (unless (defined-fun-p what) + (return-from reconstruct-lexenv)) + (push `(,(car (defined-fun-inlinep what)) + ,name) + declarations)) + (t + (unless (memq name shadowed-funs) + (return-from reconstruct-lexenv))))) + (when declarations + (setf result (list* :declare declarations (and result (list result))))) + (when symbol-macros + (setf result (list* :symbol-macro symbol-macros (and result (list result))))) + (when macros + (setf result (list* :macro macros (and result (list result))))) + while (and parent + (not (null-lexenv-p parent)))) + result)) + +;;; Return a sexpr for LAMBDA in LEXENV such that loading it from fasl +;;; preserves the original lexical environment for inlining. +;;; Return NIL if the lexical environment is too complicated. +(defun maybe-inline-syntactic-closure (lambda lexenv) + (declare (type list lambda) (type lexenv-designator lexenv)) + (aver (eql (first lambda) 'lambda)) + ;; We used to have a trivial implementation, verifying that lexenv + ;; was effectively null. However, this fails to take account of the + ;; idiom + ;; + ;; (declaim (inline foo)) + ;; (macrolet ((def (x) `(defun ,x () ...))) + ;; (def foo)) + ;; + ;; which, while too complicated for the cross-compiler to handle in + ;; unfriendly foreign lisp environments, would be good to support in + ;; the target compiler. -- CSR, 2002-05-13 and 2002-11-02 + (typecase lexenv + (lexenv + (let ((vars (lexenv-vars lexenv)) + (funs (lexenv-funs lexenv))) + (acond ((or (lexenv-blocks lexenv) (lexenv-tags lexenv)) nil) + ((and (null vars) (null funs)) lambda) + ;; If the lexenv is too hairy for cross-compilation, + ;; you'll find out later, when trying to perform inlining. + ;; This is fine, because if the inline expansion is only + ;; for the target, it's totally OK to cross-compile this + ;; defining form. The syntactic env is correctly captured. + ((reconstruct-lexenv lexenv) + `(lambda-with-lexenv ,it ,@(cdr lambda)))))) + #+(and sb-fasteval (not sb-xc-host)) + (sb-interpreter:basic-env + (awhen (sb-interpreter::reconstruct-syntactic-closure-env lexenv) + `(lambda-with-lexenv ,it ,@(cdr lambda)))) + #+sb-fasteval + (null lambda))) ; trivial case. Never occurs in the compiler. + +(declaim (end-block)) + (declaim (start-block ir1-convert-inline-lambda)) ;;; Convert the forms produced by RECONSTRUCT-LEXENV to LEXENV @@ -1124,6 +1253,7 @@ (lexenv-flushable *lexenv*) lexenv-lambda *lexenv*))) + (*inlining* (1+ *inlining*)) (clambda (ir1-convert-lambda body :source-name source-name :debug-name debug-name @@ -1138,40 +1268,38 @@ ;;; previous references. (defun get-defined-fun (name &optional (lambda-list nil lp)) (proclaim-as-fun-name name) - (when #+sb-xc-host (not *compile-time-eval*) - #-sb-xc-host (boundp '*ir1-namespace*) - (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")) - (free-funs (free-funs *ir1-namespace*))) - (note-name-defined name :function) - (cond ((not (defined-fun-p found)) - ;; This assertion is wrong in block compilation mode, for - ;; instance - ;; - ;; (defun foo (x) (bar x)) - ;; (declaim (inline bar)) - ;; (defun bar (x) x) - (aver (or (block-compile *compilation*) - (not (info :function :inlinep name)))) - (let* ((where-from (leaf-where-from found)) - (res (make-defined-fun - :%source-name name - :where-from (if (eq where-from :declared) - :declared - :defined-here) - :type (if (eq :declared where-from) - (leaf-type found) - (or (and lp - (ignore-errors - (ftype-from-lambda-list lambda-list))) - (specifier-type 'function)))))) - (substitute-leaf res found) - (setf (gethash name free-funs) res))) - ;; If FREE-FUNS has a previously converted definition - ;; for this name, then blow it away and try again. - ((defined-fun-functionals found) - (remhash name free-funs) - (get-defined-fun name lambda-list)) - (t found))))) + (let ((found (find-free-fun name "shouldn't happen! (defined-fun)")) + (free-funs (free-funs *ir1-namespace*))) + (note-name-defined name :function) + (cond ((not (defined-fun-p found)) + ;; This assertion is wrong in block compilation mode, for + ;; instance + ;; + ;; (defun foo (x) (bar x)) + ;; (declaim (inline bar)) + ;; (defun bar (x) x) + (aver (or (block-compile *compilation*) + (not (info :function :inlinep name)))) + (let* ((where-from (leaf-where-from found)) + (res (make-defined-fun + :%source-name name + :where-from (if (eq where-from :declared) + :declared + :defined-here) + :type (if (eq :declared where-from) + (leaf-type found) + (or (and lp + (ignore-errors + (ftype-from-lambda-list lambda-list))) + (specifier-type 'function)))))) + (substitute-leaf res found) + (setf (gethash name free-funs) res))) + ;; If FREE-FUNS has a previously converted definition + ;; for this name, then blow it away and try again. + ((defined-fun-functionals found) + (remhash name free-funs) + (get-defined-fun name lambda-list)) + (t found)))) ;;; Check a new global function definition for consistency with ;;; previous declaration or definition, and assert argument/result @@ -1375,27 +1503,3 @@ (specifier-type 'function)))) (values)) - -;; Similar to above, detect duplicate definitions within a file, -;; but the package lock check is unnecessary - it's handled elsewhere. -;; -;; Additionally, this is a STYLE-WARNING, not a WARNING, because there is -;; meaningful behavior that can be ascribed to some redefinitions, e.g. -;; (defmacro foo () first-definition) -;; (defun f () (use-it (foo ))) -;; (defmacro foo () other-definition) -;; will use the first definition when compiling F, but make the second available -;; in the loaded fasl. In this usage it would have made sense to wrap the -;; respective definitions with EVAL-WHEN for different situations, -;; but as long as the compile-time behavior is deterministic, it's just bad style -;; and not flat-out wrong, though there is indeed some waste in the fasl. -;; -;; KIND is the globaldb KIND of this NAME -(defun %compiler-defmacro (kind name) - (let ((name-key `(,kind ,name))) - (when (boundp '*lexenv*) - (aver (producing-fasl-file)) - ;; a slight OAOO issue here wrt %COMPILER-DEFUN - (if (member name-key (fun-names-in-this-file *compilation*) :test #'equal) - (compiler-style-warn 'same-file-redefinition-warning :name name) - (push name-key (fun-names-in-this-file *compilation*)))))) diff -Nru sbcl-2.1.1/src/compiler/ir1tran.lisp sbcl-2.1.11/src/compiler/ir1tran.lisp --- sbcl-2.1.1/src/compiler/ir1tran.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1tran.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -14,6 +14,10 @@ (declaim (special *compiler-error-bailout*)) +;;; the lexical environment we are currently converting in +(defvar *lexenv*) +(declaim (type lexenv *lexenv*)) + ;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the ;;; form number to associate with a source path. This should be bound ;;; to an initial value of 0 before the processing of each truly @@ -23,7 +27,8 @@ ;;; Report as we try each transform? (either source or IR) ;;; Bind to T to see the ones that didn't abort, -;;; or :ALL if you want to see each attempted transform. +;;; :ALL if you want to see each attempted transform. +;;; :DERIVE-TYPE for newly derived types of combinations. (defvar *show-transforms-p* nil) (declaim (inline source-form-has-path-p)) @@ -34,18 +39,29 @@ (when (source-form-has-path-p form) (gethash form *source-paths*))) -(defvar *transforming* nil) +(defvar *transforming* 0) +(defvar *inlining* 0) (defun ensure-source-path (form) - (or (get-source-path form) - (if (and *transforming* - (not (memq 'transformed *current-path*))) - ;; Don't hide all the transformed paths, since we might want - ;; to look at the final form for error reporting. - (list* (simplify-source-path-form form) - 'transformed *current-path*) - (cons (simplify-source-path-form form) - *current-path*)))) + (flet ((level> (value kind) + (let ((x (memq kind *current-path*))) + (> value + (if x + (cadr x) + 0))))) + (or (get-source-path form) + (cond ((level> *transforming* 'transformed) + ;; Don't hide all the transformed paths, since we might want + ;; to look at the final form for error reporting. + (list* (simplify-source-path-form form) + 'transformed *transforming* *current-path*)) + ;; Avoids notes about inlined code leaking out + ((level> *inlining* 'inlined) + (list* (simplify-source-path-form form) + 'inlined *inlining* *current-path*)) + (t + (cons (simplify-source-path-form form) + *current-path*)))))) (defun simplify-source-path-form (form) (if (consp form) @@ -64,6 +80,11 @@ (setf (gethash form *source-paths*) (apply #'list* 'original-source-start *current-form-number* arguments)))) +(defun proper-list (form) + (if (proper-list-p form) + form + (compiler-error "~@<~S is not a proper list.~@:>" form))) + ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph @@ -100,6 +121,34 @@ ;;;; namespace management utilities +;;; Unpack (INFO :FUNCTION :INLINING-DATA FUN-NAME). If an explicit expansion +;;; is not stored but FUN-NAME is a structure constructor, reconstitute the +;;; expansion from the defstruct description. Secondary value is T if the expansion +;;; was explicit. See SAVE-INLINE-EXPANSION-P for why we care. +;;; (Essentially, once stored then always stored, lest inconsistency result) +;;; If we have just a DXABLE-ARGS, or nothing at all, return NIL and NIL. +;;; If called on a string or anything that is not a function designator, +;;; return NIL and NIL. +(declaim (ftype (sfunction (t) (values list boolean)) + fun-name-inline-expansion)) +(defun fun-name-inline-expansion (fun-name) + (multiple-value-bind (answer winp) (info :function :inlining-data fun-name) + (typecase answer + ;; an INLINING-DATA is a DXABLE-ARGS, so test it first + (inlining-data (setq answer (inlining-data-expansion answer))) + (dxable-args (setq answer nil winp nil))) + (when (and (not winp) (symbolp fun-name)) + (let ((info (info :function :source-transform fun-name))) + (when (typep info '(cons defstruct-description (eql :constructor))) + (let* ((dd (car info)) (spec (assq fun-name (dd-constructors dd)))) + (aver spec) + (setq answer `(lambda ,@(structure-ctor-lambda-parts dd (cdr spec)))))))) + (values answer winp))) +(defun fun-name-dx-args (fun-name) + (let ((answer (info :function :inlining-data fun-name))) + (when (typep answer 'dxable-args) + (dxable-args-list answer)))) + ;; As with LEXENV-FIND, we assume use of *LEXENV*, but macroexpanders ;; receive an explicit environment and should pass it. ;; A declaration will trump a proclamation. @@ -119,9 +168,56 @@ ;; If ANSWER is NIL, go for the global value (eq (or answer (info :function :inlinep name)) 'notinline))) -#-sb-devel + +;;;; code coverage + +;;; Check the policy for whether we should generate code coverage +;;; instrumentation. If not, just return the original START +;;; ctran. Otherwise insert code coverage instrumentation after +;;; START, and return the new ctran. +(defun instrument-coverage (start mode form + &aux (metadata (coverage-metadata *compilation*))) + ;; We don't actually use FORM for anything, it's just convenient to + ;; have around when debugging the instrumentation. + (declare (ignore form)) + (if (and metadata + (policy *lexenv* (> store-coverage-data 0)) + *allow-instrumenting*) + (let ((path (source-path-original-source *current-path*))) + (when mode + (push mode path)) + (if (member (ctran-block start) + (gethash path (code-coverage-blocks metadata))) + ;; If this source path has already been instrumented in + ;; this block, don't instrument it again. + start + (let ((next (make-ctran)) + (*allow-instrumenting* nil)) + (ensure-gethash path (code-coverage-records metadata) + (cons path +code-coverage-unmarked+)) + (push (ctran-block start) + (gethash path (code-coverage-blocks metadata))) + (ir1-convert start next nil `(%primitive mark-covered ',path)) + next))) + start)) + +;;; In contexts where we don't have a source location for FORM +;;; e.g. due to it not being a cons, but where we have a source +;;; location for the enclosing cons, use the latter source location if +;;; available. This works pretty well in practice, since many PROGNish +;;; macroexpansions will just directly splice a block of forms into +;;; some enclosing form with `(progn ,@body), thus retaining the +;;; EQness of the conses. +(defun maybe-instrument-progn-like (start forms form) + (or (when (and *allow-instrumenting* + (not (get-source-path form))) + (let ((*current-path* (get-source-path forms))) + (when *current-path* + (instrument-coverage start nil form)))) + start)) + (declaim (start-block find-free-fun find-lexically-apparent-fun - ;; needed by with-fun-name-leaf + ;; needed by ir1-translators find-global-fun)) (defun maybe-defined-here (name where) @@ -228,7 +324,17 @@ (or (let ((old-free-fun (gethash name free-funs))) (when old-free-fun (clear-invalid-functionals old-free-fun) - old-free-fun)) + (when (or (not (defined-fun-p old-free-fun)) + (not (block-compile *compilation*)) + ;; When block-compiling, it is the case that we + ;; could proclaim an inline, define some things, + ;; then proclaim a notinline, and in the case that + ;; the function's :inlinep info changes, the + ;; old-free-fun is stale and we should make a new + ;; one. + (eq (info :function :inlinep name) + (defined-fun-inlinep old-free-fun))) + old-free-fun))) (let ((kind (info :function :kind name))) (ecase kind ((:macro :special-form) @@ -324,8 +430,8 @@ ;;; processed with MAKE-LOAD-FORM. We have to be careful, because ;;; CONSTANT might be circular. We also check that the constant (and ;;; any subparts) are dumpable at all. -(defun ensure-externalizable (constant) - (declare (inline alloc-xset)) +(defun maybe-emit-make-load-forms (constant) + (declare #-sb-xc-host (inline alloc-xset)) (dx-let ((xset (alloc-xset))) (named-let grovel ((value constant)) ;; Unless VALUE is an object which which can't contain other objects, @@ -346,30 +452,30 @@ (dotimes (i (length value)) (grovel (aref value i)))) ((simple-array t) - ;; Even though the (ARRAY T) branch does the exact - ;; same thing as this branch we do this separately - ;; so that the compiler can use faster versions of - ;; array-total-size and row-major-aref. + ;; Even though the (ARRAY T) branch does the exact + ;; same thing as this branch we do this separately + ;; so that the compiler can use faster versions of + ;; array-total-size and row-major-aref. (dotimes (i (array-total-size value)) (grovel (row-major-aref value i)))) ((array t) (dotimes (i (array-total-size value)) (grovel (row-major-aref value i)))) (instance - ;; In the target SBCL, we can dump any instance, but - ;; in the cross-compilation host, %INSTANCE-FOO - ;; functions don't work on general instances, only on - ;; STRUCTURE!OBJECTs. - ;; - ;; Behold the wonderfully clear sense of this- - ;; WHEN (EMIT-MAKE-LOAD-FORM VALUE) - ;; meaning "when you're _NOT_ using a custom load-form" - ;; - ;; FIXME: What about funcallable instances with - ;; user-defined MAKE-LOAD-FORM methods? + ;; In the target SBCL, we can dump any instance, but + ;; in the cross-compilation host, %INSTANCE-FOO + ;; functions don't work on general instances, only on + ;; STRUCTURE!OBJECTs. + ;; + ;; Behold the wonderfully clear sense of this- + ;; WHEN (EMIT-MAKE-LOAD-FORM VALUE) + ;; meaning "when you're _NOT_ using a custom load-form" + ;; + ;; FIXME: What about funcallable instances with + ;; user-defined MAKE-LOAD-FORM methods? (when (emit-make-load-form value) #+sb-xc-host - (aver (eql (layout-bitmap (%instance-layout value)) + (aver (eql (wrapper-bitmap (%instance-wrapper value)) sb-kernel:+layout-all-tagged+)) (do-instance-tagged-slot (i value) (grovel (%instance-ref value i))))) @@ -382,7 +488,7 @@ ;;; A constant is trivially externalizable if it involves no INSTANCE types ;;; or any un-dumpable object. (defun trivially-externalizable-p (constant) - (declare (inline alloc-xset)) + (declare #-sb-xc-host (inline alloc-xset)) (dx-let ((xset (alloc-xset))) (named-let ok ((value constant)) (if (or (dumpable-leaflike-p value) (xset-member-p value xset)) @@ -400,6 +506,23 @@ ;;;; some flow-graph hacking utilities +;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws out of the +;; body and converts a condition signalling form instead. The source +;; form is converted to a string since it may contain arbitrary +;; non-externalizable objects. +(defmacro ir1-error-bailout ((start next result form) &body body) + (with-unique-names (skip condition) + `(block ,skip + (let ((,condition (catch 'ir1-error-abort + (let ((*compiler-error-bailout* + (lambda (&optional e) + (throw 'ir1-error-abort e)))) + ,@body + (return-from ,skip nil))))) + (ir1-convert ,start ,next ,result + (make-compiler-error-form ,condition + ,form)))))) + ;;; This function sets up the back link between the node and the ;;; ctran which continues at it. (defun link-node-to-previous-ctran (node ctran) @@ -441,19 +564,10 @@ (defun insert-node-before (old new) (let ((prev (node-prev old)) (temp (make-ctran))) - (ensure-block-start prev) - (setf (ctran-next prev) nil) - (link-node-to-previous-ctran new prev) - (use-ctran new temp) - (link-node-to-previous-ctran old temp)) - (values)) - -(defun insert-node-before-no-split (old new) - (let ((prev (node-prev old)) - (temp (make-ctran))) (setf (ctran-next prev) nil) (link-node-to-previous-ctran new prev) (use-ctran new temp) + (setf (ctran-source-path temp) (ctran-source-path prev)) (link-node-to-previous-ctran old temp)) (values)) @@ -568,67 +682,55 @@ (frob) (frob) (setq trail (cdr trail))))))) + ;;;; IR1-CONVERT, macroexpansion and special form dispatching -(declaim (ftype (sfunction (ctran ctran (or lvar null) t) - (values)) - ir1-convert)) -(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws - ;; out of the body and converts a condition signalling form - ;; instead. The source form is converted to a string since it - ;; may contain arbitrary non-externalizable objects. - (ir1-error-bailout ((start next result form) &body body) - (with-unique-names (skip condition) - `(block ,skip - (let ((,condition (catch 'ir1-error-abort - (let ((*compiler-error-bailout* - (lambda (&optional e) - (throw 'ir1-error-abort e)))) - ,@body - (return-from ,skip nil))))) - (ir1-convert ,start ,next ,result - (make-compiler-error-form ,condition - ,form))))))) - - ;; Translate FORM into IR1. The code is inserted as the NEXT of the - ;; CTRAN START. RESULT is the LVAR which receives the value of the - ;; FORM to be translated. The translators call this function - ;; recursively to translate their subnodes. - ;; - ;; As a special hack to make life easier in the compiler, a LEAF - ;; IR1-converts into a reference to that LEAF structure. This allows - ;; the creation using backquote of forms that contain leaf - ;; references, without having to introduce dummy names into the - ;; namespace. - (defun ir1-convert (start next result form) - (let* ((*current-path* (ensure-source-path form)) - (start (instrument-coverage start nil form))) - (ir1-error-bailout (start next result form) - (cond ((atom form) - (cond ((and (symbolp form) (not (keywordp form))) - (ir1-convert-var start next result form)) - ((leaf-p form) - (reference-leaf start next result form)) - (t - (reference-constant start next result form)))) - ((not (proper-list-p form)) - (compiler-error "~@<~S is not a proper list.~@:>" form)) - (t - (ir1-convert-functoid start next result form))))) - (values)) - ;; Generate a reference to a manifest constant, creating a new leaf - ;; if necessary. - (defun reference-constant (start next result value) - (declare (type ctran start next) - (type (or lvar null) result)) - (ir1-error-bailout (start next result value) - (let* ((leaf (find-constant value)) - (res (make-ref leaf))) - (push res (leaf-refs leaf)) - (link-node-to-previous-ctran res start) - (use-continuation res next result))) - (values))) +(declaim (start-block ir1-convert ir1-convert-progn-body + ir1-convert-combination-args reference-leaf + reference-constant + expand-compiler-macro + maybe-reanalyze-functional)) + +;;; Translate FORM into IR1. The code is inserted as the NEXT of the +;;; CTRAN START. RESULT is the LVAR which receives the value of the +;;; FORM to be translated. The translators call this function +;;; recursively to translate their subnodes. +;;; +;;; As a special hack to make life easier in the compiler, a LEAF +;;; IR1-converts into a reference to that LEAF structure. This allows +;;; the creation using backquote of forms that contain leaf +;;; references, without having to introduce dummy names into the +;;; namespace. +(defun ir1-convert (start next result form) + (declare (type ctran start next) + (type (or lvar null) result)) + (let* ((*current-path* (ensure-source-path form)) + (start (instrument-coverage start nil form))) + (ir1-error-bailout (start next result form) + (cond ((atom form) + (cond ((and (symbolp form) (not (keywordp form))) + (ir1-convert-var start next result form)) + ((leaf-p form) + (reference-leaf start next result form)) + (t + (reference-constant start next result form)))) + (t + (ir1-convert-functoid start next result form))))) + (values)) + +;;; Generate a reference to a manifest constant, creating a new leaf +;;; if necessary. +(defun reference-constant (start next result value) + (declare (type ctran start next) + (type (or lvar null) result)) + (ir1-error-bailout (start next result value) + (let* ((leaf (find-constant value)) + (res (make-ref leaf))) + (push res (leaf-refs leaf)) + (link-node-to-previous-ctran res start) + (use-continuation res next result))) + (values)) ;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's ;;; some trivial type for which reanalysis is a trivial no-op. @@ -801,7 +903,7 @@ (let* ((op (car form)) (translator (and (symbolp op) (info :function :ir1-convert op)))) (if translator - (funcall translator start next result form) + (funcall translator start next result (proper-list form)) (multiple-value-bind (res cmacro-fun-name) (expand-compiler-macro form) (cond ((eq res form) @@ -916,9 +1018,10 @@ ;;; Convert a bunch of forms, discarding all the values except the ;;; last. If there aren't any forms, then translate a NIL. -(declaim (ftype (sfunction (ctran ctran (or lvar null) list) (values)) - ir1-convert-progn-body)) (defun ir1-convert-progn-body (start next result body) + (declare (type ctran start next) + (type (or lvar null) result) + (type list body)) (if (endp body) (reference-constant start next result nil) (let ((this-start start) @@ -937,70 +1040,6 @@ (values)) -;;;; code coverage - -;;; Check the policy for whether we should generate code coverage -;;; instrumentation. If not, just return the original START -;;; ctran. Otherwise insert code coverage instrumentation after -;;; START, and return the new ctran. -(defun instrument-coverage (start mode form - &aux (metadata (coverage-metadata *compilation*))) - ;; We don't actually use FORM for anything, it's just convenient to - ;; have around when debugging the instrumentation. - (declare (ignore form)) - (if (and metadata - (policy *lexenv* (> store-coverage-data 0)) - *allow-instrumenting*) - (let ((path (source-path-original-source *current-path*))) - (when mode - (push mode path)) - (if (member (ctran-block start) - (gethash path (code-coverage-blocks metadata))) - ;; If this source path has already been instrumented in - ;; this block, don't instrument it again. - start - (let ((store - ;; Get an interned record cons for the path. A cons - ;; with the same object identity must be used for - ;; each instrument for the same block. - (ensure-gethash path (code-coverage-records metadata) - (cons path +code-coverage-unmarked+))) - (next (make-ctran)) - (*allow-instrumenting* nil)) - #+(or x86-64 x86) (declare (ignore store)) ; eval'd for side-effect only - (push (ctran-block start) - (gethash path (code-coverage-blocks metadata))) - (ir1-convert start next nil - #+(or x86-64 x86) - `(%primitive mark-covered ',path) - #-(or x86-64 x86) - `(locally - (declare (optimize speed - (safety 0) - (debug 0) - (check-constant-modification 0))) - ;; We're being naughty here, and - ;; modifying constant data. That's ok, - ;; we know what we're doing. - (%rplacd ',store t))) - next))) - start)) - -;;; In contexts where we don't have a source location for FORM -;;; e.g. due to it not being a cons, but where we have a source -;;; location for the enclosing cons, use the latter source location if -;;; available. This works pretty well in practice, since many PROGNish -;;; macroexpansions will just directly splice a block of forms into -;;; some enclosing form with `(progn ,@body), thus retaining the -;;; EQness of the conses. -(defun maybe-instrument-progn-like (start forms form) - (or (when (and *allow-instrumenting* - (not (get-source-path form))) - (let ((*current-path* (get-source-path forms))) - (when *current-path* - (instrument-coverage start nil form)))) - start)) - ;;;; converting combinations ;;; Does this form look like something that we should add single-stepping @@ -1029,15 +1068,18 @@ ;;; Convert a function call where the function FUN is a LEAF. FORM is ;;; the source for the call. We return the COMBINATION node so that ;;; the caller can poke at it if it wants to. -(declaim (ftype (sfunction (ctran ctran (or lvar null) list leaf) combination) - ir1-convert-combination)) (defun ir1-convert-combination (start next result form fun) + (declare (type ctran start next) + (type (or lvar null) result) + (type list form) + (type leaf fun) + #-sb-xc-host (values combination)) (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun)) (let ((combination (ir1-convert-combination-args fun-lvar ctran next result - (cdr form)))) + (cdr (proper-list form))))) (when (step-form-p form) ;; Store a string representation of the form in the ;; combination node. This will let the IR2 translator know @@ -1058,7 +1100,7 @@ (declare (type ctran start next) (type lvar fun-lvar) (type (or lvar null) result) - (list args)) + (type list args)) (let ((node (make-combination fun-lvar))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) @@ -1083,10 +1125,6 @@ (setf (combination-args node) (arg-lvars)))) node)) -(defun show-transform (kind name new-form) - (let ((*print-right-margin* 100)) - (format *trace-output* "~&xform (~a) ~S~% -> ~S~%" - kind name new-form))) ;;; Convert a call to a global function. If not NOTINLINE, then we do ;;; source transforms and try out any inline expansion. If there is no ;;; expansion, but is INLINE, then give an efficiency note (unless a @@ -1108,15 +1146,22 @@ (struct-fun-transform transform form name)) ;; Note that "pass" means fail. Gotta love it. (cond (pass - (ir1-convert-maybe-predicate start next result form var)) + (ir1-convert-maybe-predicate start next result + (proper-list form) + var)) (t (unless (policy *lexenv* (zerop store-xref-data)) (record-call name (ctran-block start) *current-path*)) - (when *show-transforms-p* + (when (show-transform-p *show-transforms-p* name) (show-transform "src" name transformed)) - (let ((*transforming* t)) + (let ((*transforming* (1+ *transforming*))) + (when (eq (car *current-path*) 'original-source-start) + (setf (ctran-source-path start) *current-path*)) (ir1-convert start next result transformed))))) - (ir1-convert-maybe-predicate start next result form var)))))) + (ir1-convert-maybe-predicate start next result + (proper-list form) + var)))))) + ;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE ;;; attribute, don't generate any branch coverage instrumentation for it. @@ -1181,7 +1226,6 @@ ;;;; PROCESS-DECLS -#-sb-devel (declaim (start-block process-decls make-new-inlinep find-in-bindings process-muffle-decls @@ -1191,9 +1235,9 @@ ;;; LAMBDA-VAR for that name, or NIL if it isn't found. We return the ;;; *last* variable with that name, since LET* bindings may be ;;; duplicated, and declarations always apply to the last. -(declaim (ftype (sfunction (list symbol) (or lambda-var list)) - find-in-bindings)) (defun find-in-bindings (vars name) + (declare (list vars) (symbol name) + #-sb-xc-host (values (or lambda-var list))) (let ((found nil)) (dolist (var vars) (cond ((leaf-p var) @@ -1646,6 +1690,18 @@ (make-lexenv :default res :flushable (cdr spec))) + (current-defmethod + (destructuring-bind (name qualifiers specializers lambda-list) + (cdr spec) + (let* ((gfs (or *methods-in-compilation-unit* + (setf *methods-in-compilation-unit* + (make-hash-table :test #'equal)))) + (methods (or (gethash name gfs) + (setf (gethash name gfs) + (make-hash-table :test #'equal))))) + (setf (gethash (cons qualifiers specializers) methods) + lambda-list))) + res) (no-constraints (process-no-constraints-decl spec vars) res) @@ -1695,6 +1751,7 @@ (allow-explicit-check allow-lambda-list) (lambda-list (if allow-lambda-list :unspecified nil)) (optimize-qualities) + (local-optimize) source-form (post-binding-lexenv (if binding-form-p (list nil)))) ; dummy cell (flet ((process-it (spec decl) @@ -1737,6 +1794,12 @@ ((equal spec '(top-level-form))) ; ignore ((typep spec '(cons (eql source-form))) (setf source-form (cadr spec))) + ;; Used only for the current function. + ;; E.g. suppressing argument checking without doing + ;; so in all the subforms. + ((typep spec '(cons (eql local-optimize))) + (setf local-optimize spec) + (setf source-form (cadr spec))) (t (multiple-value-bind (new-env new-qualities) (process-1-decl spec lexenv vars fvars @@ -1752,8 +1815,11 @@ ;; Kludge: EVAL calls this function to deal with LOCALLY. (process-it spec decl))))) (warn-repeated-optimize-qualities (lexenv-policy lexenv) optimize-qualities) + (values lexenv result-type (cdr post-binding-lexenv) - lambda-list explicit-check source-form))) + lambda-list explicit-check source-form + (when local-optimize + (process-optimize-decl local-optimize (lexenv-policy lexenv)))))) (defun %processing-decls (decls vars fvars ctran lvar binding-form-p fun) (multiple-value-bind (*lexenv* result-type post-binding-lexenv) diff -Nru sbcl-2.1.1/src/compiler/ir1-translators.lisp sbcl-2.1.11/src/compiler/ir1-translators.lisp --- sbcl-2.1.1/src/compiler/ir1-translators.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1-translators.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -102,7 +102,6 @@ RETURN-FROM can be used to exit the form." (unless (symbolp name) (compiler-error "The block name ~S is not a symbol." name)) - (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) @@ -116,7 +115,6 @@ (let* ((env-entry (list entry next result)) (*lexenv* (make-lexenv :blocks (list (cons name env-entry)) :cleanup cleanup))) - (push env-entry (ctran-entries next)) (ir1-convert-progn-body dummy next result forms)))) (def-ir1-translator return-from ((name &optional value) start next result) @@ -201,7 +199,6 @@ within the lexical scope of the form, then control is transferred to the next statement following that tag. A TAG must be an integer or a symbol. A STATEMENT must be a list. Other objects are illegal within the body." - (start-block start) (ctran-starts-block next) (let* ((dummy (make-ctran)) (entry (make-entry)) @@ -298,7 +295,7 @@ ;; Do this after processing, since the definitions can be malformed. (unless (= (length definitions) (length (remove-duplicates definitions :key #'first))) - (compiler-style-warn "Duplicate definitions in ~S" definitions)) + (compiler-warn "Duplicate definitions in ~S" definitions)) (funcall fun processed-definitions))) ;;; Tweak LEXENV to include the DEFINITIONS from a MACROLET, then @@ -557,61 +554,52 @@ (compiler-error "Not a valid lambda expression:~% ~S" thing)))) -(defun fun-name-leaf (thing) +(defun enclose (start next funs) + (let ((enclose (make-enclose :funs funs))) + (link-node-to-previous-ctran enclose start) + (use-ctran enclose next) + (dolist (fun funs) + (setf (functional-enclose fun) enclose)))) + +;;; Get the leaf corresponding to THING, allocating and converting it +;;; if it's a lambda expression or otherwise finding the lexically +;;; apparent function associated to it. +(defun find-or-convert-fun-leaf (thing start) (cond - ((typep thing - '(cons (member lambda named-lambda lambda-with-lexenv))) - (values (ir1-convert-lambdalike - thing :debug-name (name-lambdalike thing)) - t)) + ((typep thing '(cons (member lambda named-lambda lambda-with-lexenv))) + (let ((ctran (make-ctran)) + (leaf (ir1-convert-lambdalike thing + :debug-name (name-lambdalike thing)))) + (enclose start ctran (list leaf)) + (values leaf ctran))) ((legal-fun-name-p thing) - (values (find-lexically-apparent-fun - thing "as the argument to FUNCTION") - nil)) + (values (find-lexically-apparent-fun thing "as the argument to FUNCTION") + start)) (t (compiler-error "~S is not a legal function name." thing)))) -(def-ir1-translator %fun-name-leaf ((thing) start next result) - (fun-name-leaf thing) +;;; Convert a lambda without referencing it, side-effecting the +;;; compile-time environment. This is useful for converting named +;;; lambdas not meant to have entry points during block compilation, +;;; since references will create entry points. +(def-ir1-translator %refless-defun ((thing) start next result) + (ir1-convert-lambdalike thing :debug-name (name-lambdalike thing)) (ir1-convert start next result nil)) -(def-ir1-translator %%allocate-closures ((&rest leaves) start next result) - (aver (eq result 'nil)) - (let ((lambdas leaves)) - ;; Opaquely quoting this list avoids recursing in find-constant - ;; to check for dumpability of sub-parts as it would otherwise do. - (ir1-convert start next result `(%allocate-closures ,(opaquely-quote lambdas))) - (let ((allocator (node-dest (ctran-next start)))) - (dolist (lambda lambdas) - (setf (functional-allocator lambda) allocator))))) - -(defmacro with-fun-name-leaf ((leaf thing start &key global-function) &body body) - `(multiple-value-bind (,leaf allocate-p) - (if ,global-function - (find-global-fun ,thing t) - (fun-name-leaf ,thing)) - (if allocate-p - (let ((.new-start. (make-ctran))) - (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf)) - (let ((,start .new-start.)) - ,@body)) - (locally - ,@body)))) - (def-ir1-translator function ((thing) start next result) "FUNCTION name Return the lexically apparent definition of the function NAME. NAME may also be a lambda expression." - (with-fun-name-leaf (leaf thing start) + (multiple-value-bind (leaf start) + (find-or-convert-fun-leaf thing start) (reference-leaf start next result leaf))) ;;; Like FUNCTION, but ignores local definitions and inline ;;; expansions, and doesn't nag about undefined functions. ;;; Used for optimizing things like (FUNCALL 'FOO). (def-ir1-translator global-function ((thing) start next result) - (with-fun-name-leaf (leaf thing start :global-function t) - (reference-leaf start next result leaf))) + (reference-leaf start next result (find-global-fun thing t))) ;;; Return T if THING is a constant value and either a symbol (if EXTENDEDP is NIL) ;;; or an extended-function-name (if EXTENDEDP is T). @@ -683,10 +671,14 @@ (let ((function (handler-case (%macroexpand function *lexenv*) (error () function)))) (if (typep function '(cons (member function global-function) (cons t null))) - (with-fun-name-leaf (leaf (cadr function) start - :global-function (eq (car function) - 'global-function)) - (ir1-convert start next result `(,leaf ,@args))) + ;; We manually frob the function to get the leaf like this so + ;; we let setf functions have their source transforms fire. + (destructuring-bind (operator definition) function + (multiple-value-bind (leaf start) + (ecase operator + (function (find-or-convert-fun-leaf definition start)) + (global-function (values (find-global-fun definition t) start))) + (ir1-convert start next result `(,leaf ,@args)))) (let ((ctran (make-ctran)) (fun-lvar (make-lvar))) (ir1-convert start ctran fun-lvar `(the function ,function)) @@ -861,7 +853,11 @@ ,@decls (block ,(fun-name-block-name name) . ,forms))))))) - (values (names) (defs)))) + (let ((names (names))) + (unless (= (length names) + (length (remove-duplicates names :test #'equal))) + (compiler-warn "Duplicate definitions in ~S" definitions)) + (values names (defs))))) (defun parse-fletish (definitions body context) (multiple-value-bind (forms declarations) (parse-body body nil) @@ -877,14 +873,13 @@ (when dx-p (ctran-starts-block ctran) (ctran-starts-block next)) - (ir1-convert start ctran nil `(%%allocate-closures ,@funs)) + (enclose start ctran funs) (cond (dx-p (let* ((dummy (make-ctran)) (entry (make-entry)) (cleanup (make-cleanup :kind :dynamic-extent :mess-up entry - :info (list (node-dest - (ctran-next start)))))) + :info (list (ctran-next start))))) (push entry (lambda-entries (lexenv-lambda *lexenv*))) (setf (entry-cleanup entry) cleanup) (link-node-to-previous-ctran entry ctran) @@ -1272,7 +1267,7 @@ :debug-name (debug-name 'escape-fun tag)))) (ctran (make-ctran))) (setf (functional-kind fun) :escape) - (ir1-convert start ctran nil `(%%allocate-closures ,fun)) + (enclose start ctran (list fun)) (reference-leaf ctran next result fun))) ;;; Yet another special special form. This one looks up a local @@ -1296,16 +1291,13 @@ ;; We represent the possibility of the control transfer by making an ;; "escape function" that does a lexical exit, and instantiate the ;; cleanup using %WITHIN-CLEANUP. - (let* ((tag-ctran (make-ctran)) - (tag-lvar (make-lvar))) - (ir1-convert start tag-ctran tag-lvar tag) - (ir1-convert - tag-ctran next result - (with-unique-names (exit-block) - `(block ,exit-block - (%within-cleanup - :catch (%catch (%escape-fun ,exit-block) ,tag-lvar) - ,@body)))))) + (ir1-convert + start next result + (with-unique-names (exit-block) + `(block ,exit-block + (%within-cleanup + :catch (%catch (%escape-fun ,exit-block) ,tag) + ,@body))))) ;;; Since NSP is restored on unwind we only need to protect against ;;; local transfers of control, basically the same as special @@ -1475,6 +1467,15 @@ (use-continuation node next result) (setf (basic-combination-args node) (arg-lvars)))))) +;;; MULTIPLE-VALUE-PROG1 is represented in IR1 by having the +;;; VALUES-FORM code use a VALUE lvar that gets handed off to +;;; RESULT. In other words, as the result continuation isn't +;;; IMMEDIATELY-USED-P by the nodes that compute the result, we have +;;; to interpose a DELAY node using RESULT immediately so that the +;;; result continuation can assume that it is immediately used. This +;;; is important here because MULTIPLE-VALUE-PROG1 is the only special +;;; form which receives unknown values with multiple uses, some (in +;;; this case one) of which are not immediate. (def-ir1-translator multiple-value-prog1 ((values-form &rest forms) start next result) "MULTIPLE-VALUE-PROG1 values-form form* @@ -1484,17 +1485,13 @@ (let* ((value-ctran (make-ctran)) (forms-ctran (make-ctran)) (value-lvar (make-lvar)) - ;; This is to avoid writing in the RESULT LVAR before the - ;; body is executed, because the body may overwrite it. - ;; See MAY-DELETE-VESTIGIAL-EXIT. - (cast (make-vestigial-exit-cast - :value value-lvar))) + (delay (make-delay :value value-lvar))) (ctran-starts-block value-ctran) (ir1-convert start value-ctran value-lvar values-form) (ir1-convert-progn-body value-ctran forms-ctran nil forms) - (link-node-to-previous-ctran cast forms-ctran) - (setf (lvar-dest value-lvar) cast) - (use-continuation cast next result))) + (link-node-to-previous-ctran delay forms-ctran) + (setf (lvar-dest value-lvar) delay) + (use-continuation delay next result))) ;;;; interface to defining macros diff -Nru sbcl-2.1.1/src/compiler/ir1util.lisp sbcl-2.1.11/src/compiler/ir1util.lisp --- sbcl-2.1.1/src/compiler/ir1util.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir1util.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -224,8 +224,7 @@ ;;; uninteresting nodes intervening. ;;; ;;; Uninteresting nodes are nodes in the same block which are either -;;; REFs, external CASTs to the same destination, or known combinations -;;; that never unwind. +;;; REFs, ENCLOSEs, or external CASTs to the same destination. (defun almost-immediately-used-p (lvar node) (declare (type lvar lvar) (type node node)) @@ -248,13 +247,8 @@ (when (and (memq (cast-type-check node) '(:external nil)) (eq dest (node-dest node))) (go :next))) - (combination - ;; KLUDGE: Unfortunately we don't have an attribute for - ;; "never unwinds", so we just special case - ;; %ALLOCATE-CLOSURES: it is easy to run into with eg. - ;; FORMAT and a non-constant first argument. - (when (eq '%allocate-closures (combination-fun-source-name node nil)) - (go :next)))))) + (enclose + (go :next))))) (t ;; Loops shouldn't cause a problem, either it will ;; encounter a not "uninteresting" node, or the destination @@ -408,7 +402,7 @@ (lambda-var-p new-lambda-var) ;; Make sure the let is inside the dx let (lexenv-contains-lambda (lambda-var-home new-lambda-var) - (cleanup-lexenv dx))) + (node-lexenv (cleanup-mess-up dx)))) (let ((new-lvar (lambda-var-ref-lvar new-ref))) (when new-lvar (propagate-lvar-dx new-lvar old-lvar t) @@ -459,84 +453,48 @@ (node-ends-block (ctran-use ctran))))) (values)) -;;; CTRAN must be the last ctran in an incomplete block; finish the -;;; block and start a new one if necessary. -(defun start-block (ctran) - (declare (type ctran ctran)) - (aver (not (ctran-next ctran))) - (ecase (ctran-kind ctran) - (:inside-block - (let ((block (ctran-block ctran)) - (node (ctran-use ctran))) - (aver (not (block-last block))) - (aver node) - (setf (block-last block) node) - (setf (node-next node) nil) - (setf (ctran-use ctran) nil) - (setf (ctran-kind ctran) :unused) - (setf (ctran-block ctran) nil) - (link-blocks block (ctran-starts-block ctran)))) - (:block-start))) ;;;; -;;; Filter values of LVAR through FORM, which must be an ordinary/mv -;;; call. Exactly one argument must be 'DUMMY, which will be replaced -;;; with LVAR. In case of an ordinary call the function should not -;;; have return type NIL. We create a new "filtered" lvar. -;;; -;;; TODO: remove preconditions. -(defun filter-lvar (lvar form) - (declare (type lvar lvar) (type list form)) +;;; Filter values of LVAR through the form produced by +;;; FUNCTION. FUNCTION takes one argument and returns a form with the +;;; argument spliced into the form exactly once. This argument is a +;;; placeholder which will be replaced with LVAR once the form is +;;; IR1 converted and the resulting code is spliced in before LVAR's +;;; DEST. The new lvar which represents the value of the form is +;;; called the "filtered" lvar. +(defun filter-lvar (lvar function) + (declare (type lvar lvar) + (type function function)) (let* ((dest (lvar-dest lvar)) - (ctran (node-prev dest))) + (ctran (node-prev dest)) + ;; We pick an arbitrary unique leaf so that IR1-convert will + ;; reference it. + (placeholder (make-constant 0)) + (form (funcall function placeholder))) (with-ir1-environment-from-node dest - (ensure-block-start ctran) (let* ((old-block (ctran-block ctran)) (new-start (make-ctran)) (filtered-lvar (make-lvar)) (new-block (ctran-starts-block new-start))) - ;; Splice in the new block before DEST, giving the new block ;; all of DEST's predecessors. (dolist (block (block-pred old-block)) (change-block-successor block old-block new-block)) - (ir1-convert new-start ctran filtered-lvar form) - ;; KLUDGE: Comments at the head of this function in CMU CL - ;; said that somewhere in here we - ;; Set the new block's start and end cleanups to the *start* - ;; cleanup of PREV's block. This overrides the incorrect - ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE. - ;; Unfortunately I can't find any code which corresponds to this. - ;; Perhaps it was a stale comment? Or perhaps I just don't - ;; understand.. -- WHN 19990521 - - ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because - ;; no LET conversion has been done yet.) The [mv-]combination - ;; code from the call in the form will be the use of the new - ;; check lvar. We substitute exactly one argument. - (let* ((node (lvar-use filtered-lvar)) - victim) - (dolist (arg (basic-combination-args node) (aver victim)) - (let* ((arg (principal-lvar arg)) - (use (lvar-use arg)) - leaf) - (when (and (ref-p use) - (constant-p (setf leaf (ref-leaf use))) - (eql (constant-value leaf) 'dummy)) - (aver (not victim)) - (setf victim arg)))) - (aver (eq (constant-value (ref-leaf (lvar-use victim))) - 'dummy)) - + ;; Replace PLACEHOLDER with the LVAR. + (let* ((refs (leaf-refs placeholder)) + (node (first refs)) + (victim (node-lvar node))) + (aver (null (rest refs))) ; PLACEHOLDER must be referenced exactly once. (substitute-lvar filtered-lvar lvar) (substitute-lvar lvar victim) (flush-dest victim)) - ;; Invoking local call analysis converts this call to a LET. + ;; The form may have introduced new local calls, for example, + ;; from LET bindings, so invoke local call analysis. (locall-analyze-component *current-component*)))) (values)) @@ -570,31 +528,19 @@ (defun %insert-cast-before (next cast) (declare (type node next) (type cast cast)) - (let* ((ctran (node-prev next)) - (lvar (cast-value cast)) - (internal-ctran (make-ctran))) - (setf (ctran-next ctran) cast - (node-prev cast) ctran) - (use-ctran cast internal-ctran) - (link-node-to-previous-ctran next internal-ctran) + (let ((lvar (cast-value cast))) + (insert-node-before next cast) (setf (lvar-dest lvar) cast) (reoptimize-lvar lvar) - (when (return-p next) - (node-ends-block cast)) cast)) (defun insert-ref-before (leaf node) - (let* ((ref (make-ref leaf)) - (lvar (make-lvar node)) - (ctran (make-ctran)) - (node-ctran (node-prev node))) + (let ((ref (make-ref leaf)) + (lvar (make-lvar node))) + (insert-node-before node ref) (push ref (leaf-refs leaf)) (setf (leaf-ever-used leaf) t) - (setf (ctran-next node-ctran) ref - (node-prev ref) node-ctran) - (use-ctran ref ctran) (use-lvar ref lvar) - (link-node-to-previous-ctran node ctran) lvar)) ;;;; miscellaneous shorthand functions @@ -603,6 +549,7 @@ ;;; the LEXENV-LAMBDA may be deleted, we must chain up the ;;; LAMBDA-CALL-LEXENV thread until we find a CLAMBDA that isn't ;;; deleted, and then return its home. +(declaim (maybe-inline node-home-lambda)) (defun node-home-lambda (node) (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) @@ -615,12 +562,14 @@ (defun lambda-parent (lambda) (lexenv-lambda (lambda-lexenv lambda))) -(declaim (ftype (sfunction (node) component) node-component)) (defun node-component (node) - (block-component (node-block node))) -(declaim (ftype (sfunction (node) physenv) node-physenv)) -(defun node-physenv (node) - (lambda-physenv (node-home-lambda node))) + (declare (type node node)) + (the component (block-component (node-block node)))) + +(declaim (maybe-inline node-environment)) +(defun node-environment (node) + (declare (type node node) #-sb-xc-host (inline node-home-lambda)) + (the environment (lambda-environment (node-home-lambda node)))) (declaim (inline node-stack-allocate-p)) (defun node-stack-allocate-p (node) @@ -702,6 +651,7 @@ ;;; actually correspond to code which will be written anywhere. (declaim (ftype (sfunction (cblock) (or clambda null)) block-home-lambda-or-null)) (defun block-home-lambda-or-null (block) + #-sb-xc-host (declare (inline node-home-lambda)) (if (node-p (block-last block)) ;; This is the old CMU CL way of doing it. (node-home-lambda (block-last block)) @@ -731,14 +681,14 @@ nil)))) ;;; Return the non-LET LAMBDA that holds BLOCK's code. -(declaim (ftype (sfunction (cblock) clambda) block-home-lambda)) (defun block-home-lambda (block) - (block-home-lambda-or-null block)) + (declare (type cblock block)) + (the clambda (block-home-lambda-or-null block))) -;;; Return the IR1 physical environment for BLOCK. -(declaim (ftype (sfunction (cblock) physenv) block-physenv)) -(defun block-physenv (block) - (lambda-physenv (block-home-lambda block))) +;;; Return the IR1 environment for BLOCK. +(defun block-environment (block) + (declare (type cblock block)) + (lambda-environment (block-home-lambda block))) ;;;; DYNAMIC-EXTENT related @@ -755,12 +705,6 @@ (leaf-debug-name leaf)))) (defun note-no-stack-allocation (lvar &key flush) - ;; If the target being compiled does not have all 4 of these features, - ;; then never warn about failure to stack-allocate. It's only useful to - ;; see when a _particular_ allocation can't go on the stack. - ;; It's just a distraction otherwise. - (declare (ignorable lvar flush)) - (do-uses (use (principal-lvar lvar)) (dolist (use (ensure-list (if (cast-p use) (principal-lvar-use (cast-value use)) @@ -802,35 +746,28 @@ (compiler-notify "~@" (find-original-source (node-source-path use))))))))) -(defun use-good-for-dx-p (use dx &optional component) - ;; FIXME: Can casts point to LVARs in other components? - ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the - ;; PRINCIPAL-LVAR is always in the same component as the original one. It - ;; would be either good to have an explanation of why casts don't point - ;; across components, or an explanation of when they do it. ...in the - ;; meanwhile AVER that our assumption holds true. - (aver (or (not component) (eq component (node-component use)))) +(defun use-good-for-dx-p (use dx) (and (not (node-to-be-deleted-p use)) (or (dx-combination-p use dx) (and (cast-p use) (not (cast-type-check use)) - (lvar-good-for-dx-p (cast-value use) dx component)) + (lvar-good-for-dx-p (cast-value use) dx)) (and (trivial-lambda-var-ref-p use) (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use)))) (or (eq use uses) - (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component))))))) + (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx))))))) -(defun lvar-good-for-dx-p (lvar dx &optional component) +(defun lvar-good-for-dx-p (lvar dx) (let ((uses (lvar-uses lvar))) (cond ((null uses) nil) ((consp uses) (every (lambda (use) - (use-good-for-dx-p use dx component)) + (use-good-for-dx-p use dx)) uses)) (t - (use-good-for-dx-p uses dx component))))) + (use-good-for-dx-p uses dx))))) (defun known-dx-combination-p (use dx) (and (eq (combination-kind use) :known) @@ -964,7 +901,7 @@ return arg)))))) ;;; This needs to play nice with LVAR-GOOD-FOR-DX-P and friends. -(defun handle-nested-dynamic-extent-lvars (dx lvar &optional recheck-component) +(defun handle-nested-dynamic-extent-lvars (dx lvar) (let ((uses (lvar-uses lvar))) ;; DX value generators must end their blocks: see UPDATE-UVL-LIVE-SETS. ;; Uses of mupltiple-use LVARs already end their blocks, so we just need @@ -979,25 +916,25 @@ (etypecase use (cast (handle-nested-dynamic-extent-lvars - dx (cast-value use) recheck-component)) + dx (cast-value use))) (combination (loop for arg in (combination-args use) ;; deleted args show up as NIL here when (and arg - (lvar-good-for-dx-p arg dx recheck-component)) + (lvar-good-for-dx-p arg dx)) append (handle-nested-dynamic-extent-lvars - dx arg recheck-component))) + dx arg))) (ref (let* ((other (trivial-lambda-var-ref-lvar use))) (unless (eq other lvar) (handle-nested-dynamic-extent-lvars - dx other recheck-component))))))) + dx other))))))) (cons (cons dx lvar) (if (listp uses) (loop for use in uses - when (use-good-for-dx-p use dx recheck-component) + when (use-good-for-dx-p use dx) nconc (recurse use)) - (when (use-good-for-dx-p uses dx recheck-component) + (when (use-good-for-dx-p uses dx) (recurse uses))))))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number @@ -1118,7 +1055,9 @@ (defun %lvar-single-value-p (lvar) (let ((dest (lvar-dest lvar))) (typecase dest - ((or creturn exit) + (exit + (lvar-single-value-p (node-lvar dest))) + (creturn nil) (mv-combination (eq (basic-combination-fun dest) lvar)) @@ -1137,11 +1076,12 @@ (defun principal-lvar-single-valuify (lvar) (loop for prev = lvar then (node-lvar dest) for dest = (and prev (lvar-dest prev)) - while (cast-p dest) + while (or (cast-p dest) + (exit-p dest)) do (setf (node-derived-type dest) (make-short-values-type (list (single-value-type (node-derived-type dest))))) - (reoptimize-lvar prev))) + (reoptimize-lvar prev))) ;;; Return a new LEXENV just like DEFAULT except for the specified ;;; slot values. Values for the alist slots are APPENDed to the @@ -1156,7 +1096,7 @@ (lexenv-disabled-package-locks default)) (policy (lexenv-policy default)) (user-data (lexenv-user-data default)) - (flushable (lexenv-flushable default)) + flushable (parent default)) (macrolet ((frob (var slot) `(let ((old (,slot default))) @@ -1288,9 +1228,8 @@ ;;; otherwise false. (defun join-successor-if-possible (block) (declare (type cblock block)) - (let* ((next (first (block-succ block))) - (start (block-start next))) - (when start ; NEXT is not an END-OF-COMPONENT marker + (let ((next (first (block-succ block)))) + (when (block-start next) ; NEXT is not an END-OF-COMPONENT marker (cond ( ;; We cannot combine with a successor block if: (or ;; the successor has more than one predecessor; @@ -1306,28 +1245,20 @@ ;; thus the control transfer is a non-local exit. (not (eq (block-home-lambda block) (block-home-lambda next))) - ;; Stack analysis phase wants ENTRY to start a block... - (entry-p (block-start-node next)) + ;; Stack analysis phase wants DX ENTRYs to start their + ;; blocks... + (let ((entry (block-start-node next))) + (and (entry-p entry) + (eq (cleanup-kind (entry-cleanup entry)) + :dynamic-extent))) (let ((last (block-last block))) (and (valued-node-p last) (awhen (node-lvar last) - (or - ;; ... and a DX-allocator to end a block. - (lvar-dynamic-extent it) - ;; ... and for there to be no chance of there - ;; being two successive USEs of the same - ;; multi-valued LVAR in the same block (since - ;; we can only insert cleanup code at block - ;; boundaries, but need to discard - ;; multi-valued LVAR contents before they are - ;; overwritten). - (and (consp (lvar-uses it)) - (not (lvar-single-value-p it))))))) + ;; ...and DX-allocators to end + ;; their blocks. + (lvar-dynamic-extent it)))) (neq (block-type-check block) - (block-type-check next)) - ;; This ctran is a destination of an EXIT, - ;; a later inlined function may want to use it. - (ctran-entries start)) + (block-type-check next))) nil) (t (join-blocks block next) @@ -1434,7 +1365,10 @@ (unless (eq type1 type2) (derive-node-type ref1 (values-type-union type1 type2) - :from-scratch t))) + :from-scratch t)) + (setf (ref-constraints ref1) + (intersection (ref-constraints ref1) + (ref-constraints ref2)))) (loop for pred in (block-pred block2) do (change-block-successor pred block2 block1)) @@ -1575,7 +1509,6 @@ ;;;; deleting stuff -#-sb-devel (declaim (start-block delete-ref delete-functional flush-node flush-dest delete-lvar delete-block delete-block-lazily delete-lambda mark-for-deletion)) @@ -1938,7 +1871,7 @@ (delete node (basic-var-sets var))))) (cast (flush-dest (cast-value node))) - (no-op))) + (enclose))) (remove-from-dfo block) (values)) @@ -1948,14 +1881,13 @@ ;;; Do stuff to indicate that the return node NODE is being deleted. (defun delete-return (node) (declare (type creturn node)) - (let ((fun (return-lambda node))) - (when fun ;; could become replaced by MOVE-RETURN-STUFF - (let ((tail-set (lambda-tail-set fun))) - (aver (lambda-return fun)) - (setf (lambda-return fun) nil) - (when (and tail-set (not (find-if #'lambda-return - (tail-set-funs tail-set)))) - (setf (tail-set-type tail-set) *empty-type*))))) + (let* ((fun (return-lambda node)) + (tail-set (lambda-tail-set fun))) + (aver (lambda-return fun)) + (setf (lambda-return fun) nil) + (when (and tail-set (not (find-if #'lambda-return + (tail-set-funs tail-set)))) + (setf (tail-set-type tail-set) *empty-type*))) (values)) ;;; If any of the VARS in FUN was never referenced and was not @@ -2046,20 +1978,9 @@ (unless (eq (functional-kind home) :deleted) (do-nodes (node nil block) (let* ((path (node-source-path node)) - (first (first path))) - (when (and (not (return-p node)) - ;; CASTs are just value filters and do not - ;; represent code and they can be moved around - ;; making CASTs from the original source code - ;; appear in code inserted by the compiler, generating - ;; false deletion notes. - ;; And if a block with the original source gets - ;; deleted the node that produces the value for - ;; the CAST will get a note, no need to note - ;; twice. - (not (cast-p node)) - ;; Nothing interesting in BIND nodes - (not (bind-p node)) + (ctran-path (ctran-source-path (node-prev node)))) + (flet ((visible-p (path) + (let ((first (first path))) (or (eq first 'original-source-start) (and (atom first) (or (not (symbolp first)) @@ -2072,14 +1993,63 @@ (present-in-form first x 0)) (source-path-forms path)) (present-in-form first (find-original-source path) - 0)))) - (let ((*compiler-error-context* node)) - (compiler-notify 'code-deletion-note - :format-control "deleting unreachable code" - :format-arguments nil)) - (return)))))) - (values)) - + 0)))))) + (cond ((and ctran-path + (visible-p ctran-path)) + (push (cons ctran-path (node-lexenv node)) + (deleted-source-paths *compilation*)) + (return)) + ((and (not (return-p node)) + ;; CASTs are just value filters and do not + ;; represent code and they can be moved around + ;; making CASTs from the original source code + ;; appear in code inserted by the compiler, generating + ;; false deletion notes. + ;; And if a block with the original source gets + ;; deleted the node that produces the value for + ;; the CAST will get a note, no need to note + ;; twice. + (not (cast-p node)) + ;; Nothing interesting in BIND nodes + (not (bind-p node)) + ;; Try to get the outer deleted node. + (not (and (valued-node-p node) + (let ((dest (node-dest node))) + (and dest + (node-to-be-deleted-p dest) + (node-source-inside-p node dest))))) + (visible-p path)) + (push (cons path (node-lexenv node)) + (deleted-source-paths *compilation*)) + (return)))))))) + (values)) + +(defun node-source-inside-p (inner-node outer-node) + (tailp (source-path-original-source (node-source-path outer-node)) + (source-path-original-source (node-source-path inner-node)))) + +(defun report-code-deletion () + (let ((forms (make-hash-table :test #'equal)) + (reversed-path)) + ;; Report only the outermost form + (loop for pair in (shiftf (deleted-source-paths *compilation*) nil) + for (path) = pair + do + (when (eq (car path) 'original-source-start) + (setf (gethash (source-path-original-source path) forms) path)) + (push pair reversed-path)) + (loop for (path . lexenv) in reversed-path + for original = (source-path-original-source path) + when (loop for outer on (if (eq (car path) 'original-source-start) + (cdr original) + original) + never (gethash outer forms)) + do + (let ((*current-path* path) + (*lexenv* lexenv)) + (compiler-notify 'code-deletion-note + :format-control "deleting unreachable code" + :format-arguments nil))))) ;;; Delete a node from a block, deleting the block if there are no ;;; nodes left. We remove the node from the uses of its LVAR. ;;; @@ -2094,7 +2064,6 @@ (declare (type node node)) (when (valued-node-p node) (delete-lvar-use node)) - (let* ((ctran (node-next node)) (next (and ctran (ctran-next ctran))) (prev (node-prev node)) @@ -2110,7 +2079,9 @@ (t (setf (ctran-next prev) next) (setf (node-prev next) prev) - (when (if-p next) ; AOP wanted + (unless (ctran-source-path prev) + (setf (ctran-source-path prev) (ctran-source-path ctran))) + (when (if-p next) (reoptimize-lvar (if-test next))))) (setf (node-prev node) nil) nil) @@ -2118,15 +2089,8 @@ (aver (eq prev-kind :block-start)) (aver (eq node last)) (let* ((succ (block-succ block)) - (next (first succ)) - (next-ctran (block-start next))) + (next (first succ))) (aver (singleton-p succ)) - ;; Update the ctran used by EXITs from BLOCKs. - (when next-ctran - (loop for entry in (ctran-entries prev) - do (setf (second entry) next-ctran)) - (setf (ctran-entries next-ctran) - (ctran-entries prev))) (cond ((eq block (first succ)) (with-ir1-environment-from-node node @@ -2355,11 +2319,37 @@ (change-ref-leaf ref new-leaf))) (values)) +;;; FIXME: This logic is incomplete, lacking PACKAGE, RANDOM-STATE, +;;; SIMPLE-VECTOR, HASH-TABLE, and PATHNAME, and all arrays of rank +;;; other than 1. SIMPLE-VECTOR, PATHNAME, and possibly RANDOM-STATE, +;;; could be worthwhile to handle. +(defun coalescible-object-p (object) + (labels ((cons-coalesce-p (x) + (when (coalesce-tree-p x) + (labels ((descend (x) + (do ((y x (cdr y))) + ((atom y) (atom-colesce-p y)) + ;; Don't just call file-coalesce-p, because + ;; it'll invoke COALESCE-TREE-P repeatedly + (let ((car (car y))) + (unless (if (consp car) + (descend car) + (atom-colesce-p car)) + (return nil)))))) + (descend x)))) + (atom-colesce-p (x) + (sb-xc:typep x '(or (unboxed-array (*)) number symbol instance character)))) + (if (consp object) + (cons-coalesce-p object) + ;; Coalescing of SYMBOL, INSTANCE, CHARACTER is not useful - + ;; if OBJECT is one of those, it would only be findable in the + ;; EQL table. However, a coalescible objects with subparts + ;; may contain those. + (sb-xc:typep object '(or (unboxed-array (*)) number))))) + ;;; Return a LEAF which represents the specified constant object. If -;;; the object is not in (CONSTANTS *IR1-NAMESPACE*), then we create a new -;;; constant LEAF and enter it. If we are producing a fasl file, make sure that -;;; MAKE-LOAD-FORM gets used on any parts of the constant that it -;;; needs to be. +;;; we are producing a fasl file, make sure that MAKE-LOAD-FORM gets +;;; used on any parts of the constant that it needs to be. ;;; ;;; We are allowed to coalesce things like EQUAL strings and bit-vectors ;;; when file-compiling, but not when using COMPILE. @@ -2400,113 +2390,80 @@ ;;; This would matter only if at load-time, the form which produced C assigns ;;; some completely different (not EQ and maybe not even similar) to the symbol. ;;; But some weird behavior was definitely observable in user code. - (defun find-constant (object &optional name - &aux (namespace (if (boundp '*ir1-namespace*) *ir1-namespace*)) - (output *compile-object*)) - - ;; Pick off some objects that aren't actually constants in user code. - ;; These things appear as literals in forms such as `(%POP-VALUES ,x) - ;; acting as a magic mechanism for passing data along. - (when (opaque-box-p object) ; quote an object without examining it - (return-from find-constant - (make-constant (opaque-box-value object) *universal-type*))) - - (when (or (core-object-p output) - ;; Git rev eded4f76 added an assertion that a named non-fixnum is referenced - ;; via its name at (defconstant +share-me-4+ (* 2 most-positive-fixnum)) - ;; I'm not sure that test makes any sense, but whatever... - (if name - (sb-xc:typep object '(or fixnum character symbol)) - (sb-xc:typep object '(or number character symbol)))) - ;; "The consequences are undefined if literal objects are destructively modified - ;; For this purpose, the following operations are considered destructive: - ;; array - Storing a new value into some element of the array ..." - ;; so a string, once used as a literal in source, becomes logically immutable. - (when (and (core-object-p output) (sb-xc:typep object '(simple-array * (*)))) - #-sb-xc-host (logically-readonlyize object nil)) - ;; "The functions eval and compile are required to ensure that literal objects - ;; referenced within the resulting interpreted or compiled code objects are - ;; the _same_ as the corresponding objects in the source code. - ;; ... - ;; The constraints on literal objects described in this section apply only to - ;; compile-file; eval and compile do not copy or coalesce constants." - ;; (http://www.lispworks.com/documentation/HyperSpec/Body/03_bd.htm) - ;; The preceding notwithstanding, numbers are always freely copyable and coaelescible. - (return-from find-constant - (if namespace - (values (ensure-gethash object (eql-constants namespace) (make-constant object))) - (make-constant object)))) - - ;; From here down, we're dealing only with COMPILE-FILE and a constant - ;; whose type is (not (or number character symbol)). - ;; CLHS 3.2.4.2.2: We are allowed to coalesce by similarity when file-compiling. - ;; But this logic is incomplete, lacking PACKAGE, RANDOM-STATE, SIMPLE-VECTOR, - ;; HASH-TABLE, and PATHNAME, and all arrays of rank other than 1. - ;; SIMPLE-VECTOR, PATHNAME, and possibly RANDOM-STATE, could be worthwhile to handle. - (labels ((cons-coalesce-p (x) - (if (eq +code-coverage-unmarked+ (cdr x)) - ;; These are already coalesced, and the CAR should - ;; always be OK, so no need to check. - t - (when (coalesce-tree-p x) - (labels ((descend (x) - (do ((y x (cdr y))) - ((atom y) (atom-colesce-p y)) - ;; Don't just call file-coalesce-p, because it'll - ;; invoke COALESCE-TREE-P repeatedly - (let ((car (car y))) - (unless (if (consp car) - (descend car) - (atom-colesce-p car)) - (return nil)))))) - (descend x))))) - (atom-colesce-p (x) - (sb-xc:typep x '(or (unboxed-array (*)) number symbol instance character)))) - (let ((coalescep - ;; When COALESCEP is true, the similarity table is "useful" for this object, - ;; and that also implies that the object is not circular. - (if (consp object) - (cons-coalesce-p object) - ;; Coalescing of SYMBOL, INSTANCE, CHARACTER is not useful - if OBJECT is - ;; one of those, it would only be findable in the EQL table. - ;; However, a coalescible objects with subparts may contain those. - (sb-xc:typep object '(or (unboxed-array (*)) number))))) - - ;; If the constant is named, always look in the named-constants table first. - ;; This ensure that there is no chance of referring to the constant at load-time - ;; through an access path other than `(SYMBOL-GLOBAL-VALUE ,name). - ;; Additionally, replace any unnamed constant that is similar to this one - ;; with the named constant. (THIS IS VERY SUSPICIOUS) - (when name - (return-from find-constant - (or (gethash name (named-constants namespace)) - (let ((new (make-constant object (ctype-of object) name))) - (setf (gethash name (named-constants namespace)) new) - ;; If there was no EQL constant, or an unnamed one, add NEW - (let ((old (gethash object (eql-constants namespace)))) - (when (or (not old) (eq (leaf-%source-name old) '.anonymous.)) - (setf (gethash object (eql-constants namespace)) new))) - ;; Same for SIMILAR table, if coalescible - (when coalescep - (let ((old (get-similar object (similar-constants namespace)))) - (when (or (not old) (eq (leaf-%source-name old) '.anonymous.)) - (setf (get-similar object (similar-constants namespace)) new)))) - new)))) - - ;; Has the identical object or a similar object been seen before? - (let ((found (or (gethash object (eql-constants namespace)) - (and coalescep - (get-similar object (similar-constants namespace)))))) - (when found - (return-from find-constant found))) - - (ensure-externalizable object) - (let ((new (make-constant object))) - (setf (gethash object (eql-constants namespace)) new) - (when coalescep - (setf (get-similar object (similar-constants namespace)) new)) - new)))) + &aux (namespace (if (boundp '*ir1-namespace*) *ir1-namespace*))) + (when (or #+metaspace (typep object 'sb-vm:layout)) + (error "Cowardly refusing to FIND-CONSTANT on a LAYOUT")) + + (cond + ;; Pick off some objects that aren't actually constants in user + ;; code. These things appear as literals in forms such as + ;; `(%POP-VALUES ,x) acting as a magic mechanism for passing data + ;; along. + ((opaque-box-p object) ; quote an object without examining it + (make-constant (opaque-box-value object) *universal-type*)) + ((not (producing-fasl-file)) + ;; "The consequences are undefined if literal objects are destructively modified + ;; For this purpose, the following operations are considered destructive: + ;; array - Storing a new value into some element of the array ..." + ;; so a string, once used as a literal in source, becomes logically immutable. + #-sb-xc-host + (when (sb-xc:typep object '(simple-array * (*))) + (logically-readonlyize object nil)) + ;; "The functions eval and compile are required to ensure that literal objects + ;; referenced within the resulting interpreted or compiled code objects are + ;; the _same_ as the corresponding objects in the source code. + ;; ... + ;; The constraints on literal objects described in this section apply only to + ;; compile-file; eval and compile do not copy or coalesce constants." + ;; (http://www.lispworks.com/documentation/HyperSpec/Body/03_bd.htm) + ;; The preceding notwithstanding, numbers are always freely copyable and coalescible. + (if namespace + (values (ensure-gethash object (eql-constants namespace) (make-constant object))) + (make-constant object))) + ((if name + ;; Git rev eded4f76 added an assertion that a named non-fixnum is referenced + ;; via its name at (defconstant +share-me-4+ (* 2 most-positive-fixnum)) + ;; I'm not sure that test makes any sense, but whatever... + (sb-xc:typep object '(or fixnum character symbol)) + (sb-xc:typep object '(or number character symbol))) + (values (ensure-gethash object (eql-constants namespace) (make-constant object)))) + (t + ;; CLHS 3.2.4.2.2: We are allowed to coalesce by similarity when + ;; file-compiling. + (let ((coalescep (coalescible-object-p object))) + ;; When COALESCEP is true, the similarity table is "useful" for + ;; this object. + (if name + ;; If the constant is named, always look in the named-constants table first. + ;; This ensure that there is no chance of referring to the constant at load-time + ;; through an access path other than `(SYMBOL-GLOBAL-VALUE ,name). + ;; Additionally, replace any unnamed constant that is similar to this one + ;; with the named constant. (THIS IS VERY SUSPICIOUS) + (or (gethash name (named-constants namespace)) + (let ((new (make-constant object (ctype-of object) name))) + (setf (gethash name (named-constants namespace)) new) + ;; If there was no EQL constant, or an unnamed one, add NEW + (let ((old (gethash object (eql-constants namespace)))) + (when (or (not old) (not (leaf-has-source-name-p old))) + (setf (gethash object (eql-constants namespace)) new))) + ;; Same for SIMILAR table, if coalescible + (when coalescep + (let ((old (get-similar object (similar-constants namespace)))) + (when (or (not old) (not (leaf-has-source-name-p old))) + (setf (get-similar object (similar-constants namespace)) new)))) + new)) + ;; If the constant is anonymous, just make a new constant + ;; unless it is EQL or similar to an existing leaf. + (or (gethash object (eql-constants namespace)) + (and coalescep + (get-similar object (similar-constants namespace))) + (let ((new (make-constant object))) + (maybe-emit-make-load-forms object) + (setf (gethash object (eql-constants namespace)) new) + (when coalescep + (setf (get-similar object (similar-constants namespace)) new)) + new))))))) ;;; Return true if X and Y are lvars whose only use is a ;;; reference to the same leaf, and the value of the leaf cannot @@ -2560,7 +2517,7 @@ (let* ((entry (exit-entry exit)) (cleanup (entry-cleanup entry)) (block (first (block-succ (node-block exit))))) - (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) + (dolist (nlx (environment-nlx-info (node-environment entry)) nil) (when (and (eq (nlx-info-block nlx) block) (eq (nlx-info-cleanup nlx) cleanup)) (return nlx))))) @@ -2759,10 +2716,11 @@ (let ((info (basic-combination-fun-info call))) (and (not (fun-info-ir2-convert info)) + (not (fun-info-ltn-annotate info)) (dolist (template (fun-info-templates info) t) (when (eq (template-ltn-policy template) :fast-safe) (multiple-value-bind (val win) - (valid-fun-use call (template-type template)) + (valid-fun-use call (template-type template)) (when (or val (not win)) (return nil))))))))))) ;;;; careful call @@ -2961,6 +2919,7 @@ ;;; from system lambdas. (defun preserve-single-use-debug-var-p (call var) (and (policy call (eql preserve-single-use-debug-variables 3)) + (not (lambda-var-specvar var)) (or (not (lambda-var-p var)) (not (lambda-system-lambda-p (lambda-var-home var)))))) diff -Nru sbcl-2.1.1/src/compiler/ir2opt.lisp sbcl-2.1.11/src/compiler/ir2opt.lisp --- sbcl-2.1.1/src/compiler/ir2opt.lisp 2021-01-30 11:22:38.000000000 +0000 +++ sbcl-2.1.11/src/compiler/ir2opt.lisp 2021-11-30 16:16:46.000000000 +0000 @@ -19,8 +19,8 @@ ;;; For blocks it's a cons with (pred . succ) ;;; For labels it maps to the label block (defvar *2block-info*) -(defmacro vop-predecessors (vop) `(car (gethash ,vop *2block-info*))) -(defmacro vop-successors (vop) `(cdr (gethash ,vop *2block-info*))) +(defmacro ir2block-predecessors (x) `(car (gethash (the ir2-block ,x) *2block-info*))) +(defmacro ir2block-successors (x) `(cdr (gethash (the ir2-block ,x) *2block-info*))) (defun initialize-ir2-blocks-flow-info (component) (labels ((block-last-2block (block) @@ -67,7 +67,7 @@ (remove 2block (car info))))) (setf (cdr info) succ) (dolist (new succ) - (pushnew 2block (vop-predecessors new)))))) + (pushnew 2block (ir2block-predecessors new)))))) ;;;; Conditional move insertion support code (defun move-value-target (2block) @@ -110,6 +110,11 @@ (values (block-label (car succ-a)) target value-a value-b))))))) +#-x86-64 +(defun sb-vm::computable-from-flags-p (res x y flags) + (declare (ignorable res x y flags)) + nil) + ;; To convert a branch to a conditional move: ;; 1. Convert both possible values to the chosen common representation ;; 2. Execute the conditional VOP @@ -122,13 +127,24 @@ target res flags info label - vop node 2block) - (let ((prev (vop-prev vop))) - (delete-vop vop) - (flet ((reuse-if-eq-arg (value-if vop) + vop node 2block + &aux (prev (vop-prev vop))) + (delete-vop vop) + (cond + ((and (constant-tn-p arg-if) + (constant-tn-p arg-else) + (sb-vm::computable-from-flags-p + res (tn-value arg-if) (tn-value arg-else) flags)) + (emit-template node 2block (template-or-lose 'sb-vm::compute-from-flags) + (reference-tn-list (list arg-if arg-else) nil) + (reference-tn res t) + (list* flags info))) + (t + (flet ((reuse-if-eq-arg (value-if vop) ;; Most of the time this means: ;; if X is already NIL, don't load it again. - (when (and (eq (vop-name vop) 'if-eq) + (when (and vop + (eq (vop-name vop) 'if-eq) (constant-tn-p value-if)) (let* ((args (vop-args vop)) (x-tn (tn-ref-tn args)) @@ -139,84 +155,74 @@ (eq (tn-primitive-type x-tn) (tn-primitive-type res))) x-tn)))) - (load-and-coerce (dst src) + (load-and-coerce (dst src) (when (and dst (neq dst src)) (emit-and-insert-vop node 2block (template-or-lose 'move) (reference-tn src nil) (reference-tn dst t) (ir2-block-last-vop 2block))))) - (let ((reuse (reuse-if-eq-arg value-if prev))) - (if reuse - (setf arg-if reuse) - (load-and-coerce arg-if value-if))) - (load-and-coerce arg-else value-else)) - (emit-template node 2block (template-or-lose cmove-vop) - (reference-tn-list (remove nil (list arg-if arg-else)) - nil) - (reference-tn res t) - (list* flags info)) + (let ((reuse (reuse-if-eq-arg value-if prev))) + (if reuse + (setf arg-if reuse) + (load-and-coerce arg-if value-if))) + (load-and-coerce arg-else value-else)) + (emit-template node 2block (template-or-lose cmove-vop) + (reference-tn-list (remove nil (list arg-if arg-else)) + nil) + (reference-tn res t) + (list* flags info)))) (emit-move node 2block res target) (vop branch node 2block label) - (update-block-succ 2block (list label)))) + (update-block-succ 2block (list label))) -;; Since conditional branches are always at the end of blocks, -;; it suffices to look at the last VOP in each block. -(defun maybe-convert-one-cmov (2block) - (let ((vop (or (ir2-block-last-vop 2block) - (return-from maybe-convert-one-cmov)))) - (unless (eq (vop-name vop) 'branch-if) - (return-from maybe-convert-one-cmov)) - ;; The test and branch-if may be split between two IR1 blocks - ;; due to cleanups, can't use bloc-succ of the ir2-block-block - (let* ((node (vop-node vop)) - (succ (block-succ (node-block node))) - (a (first succ)) - (b (second succ))) - - (destructuring-bind (jump-target not-p flags) (vop-codegen-info vop) - (multiple-value-bind (label target value-a value-b) - (cmovp jump-target a b) - (unless label +(defun maybe-convert-one-cmov (vop) + ;; The test and branch-if may be split between two IR1 blocks + ;; due to cleanups, can't use bloc-succ of the ir2-block-block + (let* ((node (vop-node vop)) + (succ (block-succ (node-block node))) + (a (first succ)) + (b (second succ))) + + (destructuring-bind (jump-target not-p flags) (vop-codegen-info vop) + (multiple-value-bind (label target value-a value-b) + (cmovp jump-target a b) + (unless label + (return-from maybe-convert-one-cmov)) + (multiple-value-bind (cmove-vop arg-a arg-b res info) + (convert-conditional-move-p node target value-a value-b) + (unless cmove-vop (return-from maybe-convert-one-cmov)) - (multiple-value-bind (cmove-vop arg-a arg-b res info) - (convert-conditional-move-p node target value-a value-b) - (unless cmove-vop - (return-from maybe-convert-one-cmov)) - (when not-p - (rotatef value-a value-b) - (rotatef arg-a arg-b)) - (flet ((safe-coercion-p (from to) - (let ((from (tn-primitive-type from)) - (to (tn-primitive-type to))) - ;; These moves will be repositioned before the test VOP, - ;; which may be restricting their type. - ;; Avoid the moves that may touch memory and - ;; thus fail on immediate values. - (not (and (eq from *backend-t-primitive-type*) - (memq (primitive-type-name to) - '(#+64-bit sb-vm::unsigned-byte-64 - #+64-bit sb-vm::unsigned-byte-63 - #+64-bit sb-vm::signed-byte-64 - #-64-bit sb-vm::unsigned-byte-32 - #-64-bit sb-vm::unsigned-byte-31 - #-64-bit sb-vm::signed-byte-32 - #-64-bit single-float - double-float - complex-single-float - complex-double-float - system-area-pointer))))))) - (if (and (safe-coercion-p value-a arg-a) + (when not-p + (rotatef value-a value-b) + (rotatef arg-a arg-b)) + (flet ((safe-coercion-p (from to) + (let ((from (tn-primitive-type from)) + (to (tn-primitive-type to))) + ;; These moves will be repositioned before the test VOP, + ;; which may be restricting their type. + ;; Avoid the moves that may touch memory and + ;; thus fail on immediate values. + (not (and (eq from *backend-t-primitive-type*) + (memq (primitive-type-name to) + '(#+64-bit sb-vm::unsigned-byte-64 + #+64-bit sb-vm::unsigned-byte-63 + #+64-bit sb-vm::signed-byte-64 + #-64-bit sb-vm::unsigned-byte-32 + #-64-bit sb-vm::unsigned-byte-31 + #-64-bit sb-vm::signed-byte-32 + #-64-bit single-float + double-float + complex-single-float + complex-double-float + system-area-pointer))))))) + (when (and (safe-coercion-p value-a arg-a) (safe-coercion-p value-b arg-b)) - (convert-one-cmov cmove-vop value-a arg-a - value-b arg-b - target res - flags info - label vop node 2block))))))))) - -(defun convert-cmovs (component) - (do-ir2-blocks (2block component (values)) - (maybe-convert-one-cmov 2block))) + (convert-one-cmov cmove-vop value-a arg-a + value-b arg-b + target res + flags info + label vop node (vop-block vop))))))))) (defun delete-unused-ir2-blocks (component) (declare (type component component)) @@ -283,7 +289,23 @@ (let ((x (tn-ref-tn args)) (y (tn-ref-tn results))) (when (location= x y) - (delete-vop vop))))))))) + (delete-vop vop) + ;; Deleting the copy may make it look like that register + ;; is not used anywhere else and some optimizations, + ;; like combine-instructions, may incorrectly trigger. + ;; FIXME: these tn-refs never go away, so things like + ;; combine-instructions should use a different mechanism + ;; for checking writes/reads. + (let ((x-reads (tn-reads x)) + (x-writes (tn-writes x))) + (when (tn-reads y) + (reference-tn x nil)) + (when (tn-writes y) + (reference-tn x t)) + (when x-reads + (reference-tn y nil)) + (when x-writes + (reference-tn y t))))))))))) ;;; Unchain BRANCHes that jump to a BRANCH. ;;; Remove BRANCHes that are jumped over by BRANCH-IF @@ -421,16 +443,34 @@ (defun next-vop (vop) (or (vop-next vop) - (let ((next-block (ir2-block-next (vop-block vop)))) - (and (not (or (ir2-block-%trampoline-label next-block) - (ir2-block-%label next-block))) - (ir2-block-start-vop next-block))))) + (do ((2block (ir2-block-next (vop-block vop)) + (ir2-block-next 2block))) + ((null 2block) nil) + (cond ((or (ir2-block-%trampoline-label 2block) + (ir2-block-%label 2block)) + (return)) + ((ir2-block-start-vop 2block) + (return (ir2-block-start-vop 2block))))))) + +(defun prev-vop (vop) + (or (vop-prev vop) + (do* ((2block (vop-block vop) prev) + (prev (ir2-block-prev 2block) + (ir2-block-prev 2block))) + ((null prev) nil) + (cond ((or (ir2-block-%trampoline-label 2block) + (ir2-block-%label 2block)) + (return)) + ((ir2-block-last-vop prev) + (return (ir2-block-last-vop prev))))))) (defun immediate-templates (fun &optional (constants t)) (let ((primitive-types (list (primitive-type-or-lose 'character) (primitive-type-or-lose 'fixnum) (primitive-type-or-lose 'sb-vm::positive-fixnum) + #-x86 ;; i387 is weird (primitive-type-or-lose 'double-float) + #-x86 (primitive-type-or-lose 'single-float) . #+(or 64-bit 64-bit-registers) @@ -482,35 +522,41 @@ args1) args2))) -;;; Turn CMP X,Y BRANCH-IF M CMP X,Y BRANCH-IF N -;;; into CMP X,Y BRANCH-IF M BRANCH-IF N -;; while it's portable the VOPs are not validated for -;; compatibility on other backends yet. -#+(or arm arm64 x86 x86-64) (defoptimizer (vop-optimize branch-if) (branch-if) - (let ((prev (vop-prev branch-if))) - (when (and prev - (memq (vop-name prev) *comparison-vops*)) - (let ((next (next-vop branch-if)) - transpose) - (when (and next - (memq (vop-name next) *comparison-vops*) - (or (vop-args-equal prev next) - (and (or (setf transpose - (memq (vop-name prev) *commutative-comparison-vops*)) - (memq (vop-name next) *commutative-comparison-vops*)) - (vop-args-equal prev next t)))) - (when transpose - ;; Could flip the flags for non-commutative operations - (loop for tn-ref = (vop-args prev) then (tn-ref-across tn-ref) - for arg in (nreverse (vop-arg-list prev)) - do (change-tn-ref-tn tn-ref arg))) - (delete-vop next)))))) + (cond ((boundp '*2block-info*) + (maybe-convert-one-cmov branch-if)) + #+(or arm arm64 x86 x86-64) + (t + ;; Turn CMP X,Y BRANCH-IF M CMP X,Y BRANCH-IF N + ;; into CMP X,Y BRANCH-IF M BRANCH-IF N + ;; Run it after CMOVs are converted. + ;; While it's portable the VOPs are not validated for + ;; compatibility on other backends yet. + (let ((prev (vop-prev branch-if))) + (when (and prev + (memq (vop-name prev) *comparison-vops*)) + (let ((next (next-vop branch-if)) + transpose) + (when (and next + (memq (vop-name next) *comparison-vops*) + (or (vop-args-equal prev next) + (and (or (setf transpose + (memq (vop-name prev) *commutative-comparison-vops*)) + (memq (vop-name next) *commutative-comparison-vops*)) + (vop-args-equal prev next t)))) + (when transpose + ;; Could flip the flags for non-commutative operations + (loop for tn-ref = (vop-args prev) then (tn-ref-across tn-ref) + for arg in (nreverse (vop-arg-list prev)) + do (change-tn-ref-tn tn-ref arg))) + (setf (sb-assem::label-comment (car (vop-codegen-info branch-if))) + :merged-ifs) + (delete-vop next)))))))) (defun next-start-vop (block) (loop for 2block = block then (ir2-block-next 2block) while (and 2block - (= (length (vop-predecessors 2block)) 1)) + (= (length (ir2block-predecessors 2block)) 1)) when (ir2-block-start-vop 2block) return it)) (defun branch-destination (branch &optional (true t)) @@ -520,6 +566,70 @@ (next-start-vop (ir2-block-next (vop-block branch))) (next-start-vop (gethash label *2block-info*))))) +;;; Replace (BOUNDP X) + (BRANCH-IF) + {(SYMBOL-VALUE X) | anything} +;;; by (FAST-SYMBOL-VALUE X) + (UNBOUND-MARKER-P) + BRANCH-IF +;;; and delete SYMBOL-VALUE, with the result of FAST-SYMBOL-VALUE flowing +;;; into the same TN as symbol-value's result. +;;; This is a valid substitution on any of the architectures, but +;;; it requires that UNBOUND-MARKER-P return its result in a flag, +;;; so presently is enabled only for x86-64. +#+x86-64 +(defoptimizer (vop-optimize boundp) (vop) + (let ((sym (tn-ref-tn (vop-args vop))) + (next (vop-next vop))) + (unless (and (boundp '*2block-info*) + next (eq (vop-name next) 'branch-if)) + (return-from vop-optimize-boundp-optimizer nil)) + ;; Only replace if the BOUNDP=T consequent starts with SYMBOL-VALUE so that + ;; a bad example such as (IF (BOUNDP '*FOO*) (PRINT 'HI) *FOO*) + ;; - which has SYMBOL-VALUE as the wrong consequent of the IF - is unaffected. + (let* ((successors (ir2block-successors (vop-block next))) + (info (vop-codegen-info next)) + (label-block (gethash (car info) *2block-info*)) + (symeval-vop + (ir2-block-start-vop + (cond ((eq (second info) nil) label-block) ; not negated test. + ;; When negated, the BOUNDP case goes to the "other" successor + ;; block, i.e. whichever is not started by the #